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1. 


Introduction 


The  Digital  Emulation  Technology  Laboratory  (formerly  referred  to  as  the  KEW  Digital 
Emulation  Laboratory)  is  a  principal  unit  within  the  Computer  Engineering  Research  Laboratory 
(CERL)  at  Georgia  Tech.  This  report  addresses  the  objectives,  requirements,  and  schedule  of  the 
Digital  Emulation  Technology  Laboratory  (DETL),  relative  to  contract  number  DASG60-85-C- 
0041.  An  associated  report,  "Annual  Report  --  Task  1:  Digital  Emulation  Technology 
Laboratory"  covers  DETL  relative  to  contract  number  DASG60-89-C-0142.  The  major 
distinction  between  these  two  contracts  and  their  associated  activity  at  DETL  is  that  the  newer 
contract  concerns  primarily  activity  associated  with  the  effort  to  develop  an  integrated  hardware 
and  software  environment  for  end-to-end  simulations  of  exoatmospheric  interceptors  such  as 
EXOSIM.  This  report,  on  the  other  hand,  focuses  more  on  the  basic  hardware  and  system 
software  that  was  developed  at  Georgia  Tech  and  eventually  applied  to  these  end-to-end 
simulations.  This  includes  the  Georgia  Tech  Parallel  Function  Processor  (PFP),  the  older  system 
software  for  the  PFP  (utilities  and  parallel  programming  tools),  and  earlier  application  software 
(prior  to  EXOSIM). 


1.1.  Objectives 

Within  DETL,  there  are  two  main  hardware  systems:  the  Parallel  Function  Processor  (PFP)  and 
the  Seeker  Scene  Emulator  (SSE).  Each  of  these  systems  is  a  complex  parallel  processor, 
designed  to  function  together  as  an  emulation  facility  for  kinetic  energy  weapons  systems. 
Software  development  is  also  an  active  area  of  research,  both  at  the  system  level  (compilers, 
loaders,  graphics  development)  and  at  the  application  level  (simulation  and  emulation  studies). 

The  principal  objectives  of  DETL  are  as  follows: 

-  Provide  facilities  for  6-DOF  KEW  emulation 

-  Provide  real-time  capability  in  excess  of  2000  Hz 


-  Provide  real-time  emulation  of  IR  FPA  seekers 

-  Test  and  verify  GN&C  software  and  hardware  systems 

-  Educate  new  PFP  users  and  provide  technical  support. 


Figure  1.1:  Major  components  of  DETL 

The  major  components  used  in  meeting  these  objectives  include  the  PFP,  SSE,  high-speed  3-D 
graphics  workstation,  and  associated  conventional  computers  for  basic  support  functions.  Not  all 
of  these  components  are  required  for  every  task.  For  example,  much  of  our  work  consists  of 
running  simulations  (sometimes  real-time,  sometimes  not)  on  the  PFP,  with  no  attached 
systems.  This  limited  mode  of  operation  is  capable  of  verifying  missile  simulation  models  and 
control  laws,  as  well  as  many  types  of  signal  processing. 
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To  provide  realistic  imagery  in  real-time,  however,  the  Seeker  Scene  Emulator  is  required.  This 
system  generates  image  data  as  though  it  were  coming  directly  off  of  the  elements  of  a  focal- 
plane  array,  with  the  scene  information  determined  by  the  relative  location  of  the  simulated 
missile  system  to  the  targets  and  decoys. 

Actual  flight  hardware  may  be  tested  within  this  system,  as  indicated  by  Figure  1.1.  Most  of  the 
items  contained  in  the  lower  half  of  this  figure  represent  VLSI  components  that  may  be  tested 
within  DETL.  The  GT-DP  blocks,  for  example,  are  chips  for  guidance  and  control  processing 
that  are  being  developed  at  Georgia  Tech.  Similarly,  the  GT-SP  block  contains  signal-processing 
components  developed  at  Georgia  Tech.  By  equipping  the  hardware  with  appropriate  interfaces 
to  the  PFP,  the  simulated  functions  of  the  GN&C  Processor  can  migrate  from  the  PFP  to  the 
actual  hardware.  These  interfaces  are  also  shown  in  the  figure.  Additional  detail  on  the  VLSI 
components  themselves  may  be  found  in  Volume  4  of  this  final  report.. 


1.2.  Schedules  and  milestones 

As  of  July  1990,  there  are  three  32-processor  PFP  systems  available.  One  of  these  is  currently 
undergoing  a  transition  from  an  earlier  configuration  to  our  latest  3-processor-rack  configuration, 
with  386-based  processors  to  replace  the  original  286-based  processors.  The  other  two  systems 
are  the  286-based  machine  allocated  for  KDEC  and  the  FPP-based  machine  for  internal 
development  of  FPP/Sun  host  software.  Not  included  in  these  3  PFPs  are  a  limited  test  PFP 
system  and  the  prototype  Multibus  II  PFP  system.  Since  last  year,  we  have  taken  our  older 
8086-based  PFP  out  of  service. 

The  FPP-based  PFP  and  the  KDEC  PFP  both  include  the  basic  packaging  and  power  supplies  to 
support  expansion  to  64-processor  capability.  The  386-based  PFP  may  eventually  be  paired  with 
the  Multibus  II  PFP  to  produce  a  64-processor  hybrid  system. 

The  major  milestones  completed  over  the  period  of  this  report  are  as  follows: 

-  Integration  of  386/12  processors  into  the  PFP,  making  the  286/12  processors 
available  for  the  KDEC  PFP, 
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-  Demonstration  of  the  256-processor  Seeker  Scene  Emulator  generating  frames  at 

64  frames/second,  with  image  control  information  supplied  by  the  PFP  in 
realtime, 

-  Upgrades  to  the  crossbar  compiler  to  support  multiple  crossbars, 

-  Transition  to  a  new  host  operating  system  (RMX  II),  allowing  greater  memory 

accessibility,  virtual  terminal  support,  and  other  features, 

-  Upgrades  to  the  Floating-Point  Processor  (FPP)  Compiler  to  support  migration  to 

a  new  host, 

-  Development  of  utility  software  on  the  new  system,  replacing  (and  enhancing) 

basic  functions  for  loading  and  starting  programs, 

-  Development  of  programming  tools  for  the  new  system,  including  a  "make"  utility 

for  application  maintenance, 

-  Development  of  parallel-processing  support  utilities,  including  one  that  analyzes 

variable  usage  across  partitions  and  one  that  automatically  generates 
communication  calls, 

-  Development  of  libraries  of  communication  procedures  for  processor-processor 

and  processor-host  interaction,  providing  uniform  interfaces  across  several 
languages  (C,  Fortran,  Pascal,  and  PL/M), 

-  Design  and  development  of  a  new  "piggyback"  board  to  provide  crossbar 

communcation  capability  to  the  386/12  boards  through  their  iSBX  interfaces, 

-  Design  modifications  to  the  Multibus  Repeater  boards  to  support  expanded 

memory  accessibility  (16  MBytes  per  rack,  over  48  MBytes  per  32-processor 
system), 

-  Design  modifications  to  the  286/12  processors  to  make  them  completely 

interchangeable  with  386/12  boards  in  the  new,  expanded-memory 
configuration, 

-  System-level  repackaging  (racks,  power  supplies,  cabling), 

-  Presentation  of  onsite  education  in  PFP  programming, 

-  Hardware  and  software  documentation  for  the  PFP  Technical  Data  Package, 
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-  Definition  of  basic  rules  for  developing  parallel  applications  in  FORTRAN  and  in 

ACSL  on  conventional  single-processor  systems, 

-  Application  of  these  rules  in  versions  of  EXOSIM  by  Dynetics,  followed  by 

successful  porting  of  4-  and  5-processor  versions  to  the  PFP. 

-  Development  of  new  firmware  for  286/12  boards  to  support  their  use  as  target 

processors, 

-  Pascal  compiler  running  on  FPPs. 

Some  of  these  items  are  more  closely  related  to  the  work  effort  of  the  new  contract  (DASG60-89- 
C-0142),  and  are  therefore  described  in  that  report. 


1.3.  Long-range  Plans 

Georgia  Tech’s  parallel  architectures  continue  to  evolve.  Already  in  progress  is  the  development 
of  a  PFP  based  on  a  newer  computer  bus,  the  Multibus  n.  With  this  high-performance  bus,  an 
additional  interconnection  path  is  available  between  processors,  more  suitable  for  occasional 
transfers  of  large  amounts  of  data.  A  new  interconnection  scheme  between  racks  of  processors 
will  allow  multiple  PFPs  to  be  interconnected  more  freely  than  ever  before. 

Beyond  the  PFP,  a  new  dynamic  crossbar  architecture  is  in  the  design  stage.  Unlike  the  current 
crossbar,  which  pre-schedules  all  of  the  communication  between  processors,  the  new  architecture 
will  allow  processors  to  communicate  at  their  own  pace,  even  changing  the  system  to  meet  each 
processor's  changing  requirements. 

Such  an  architecture  is  suitable  for  more  general  problems,  like  the  simulation  of  molecular 
dynamics  or  compressible  fluid  flow.  It  will  also  be  the  best  architecture  to  handle  SDI's  battle 
management  problem.  In  this  application,  a  computer  must  respond  quickly  to  a  variety  of 
potential  threats.  A  dynamic  crossbar  system  would  provide  both  the  required  number  of 
processors  and  the  fast  communication  paths. 

Although  we  have  already  developed  a  complete  set  of  software  tools  that  meet  our  own  research 
requirements,  there  is  a  need  for  general  programming  aids,  particularly  for  users  not  accustomed 
to  specialized  computers.  A  graphic  interface  has  been  prototyped  which  provides  users  with  the 


capability  of  entering  simulation  models  directly  as  block  diagrams.  Other  tools  would 
automatically  partition  large  problems  among  the  available  processors. 

At  the  same  time,  we  will  continue  to  apply  the  best  available  chip  technology  to  our  designs, 
including  both  VLSI  and  VHSIC,  where  applicable. 

1.4.  Report  Summary 

The  remainder  of  this  report  will  describe  the  hardware  and  software  associated  with  the  Digital 
Emulation  Technology  Laboratory,  with  an  emphasis  on  the  work  completed  during  the  previous 
contract  year.  The  hardware  information  includes  updated  status  of  the  PFP  units,  new 
processors,  host  enhancements,  communication  interfaces,  improved  coprocessor  performance, 
and  new  firmware.  A  brief  description  is  also  given  for  the  physical  facility  itself  and  some 
auxiliary  computers  contained  within.  The  software  information  includes  new  versions  of 
utilities  which  support  the  GT-FPP  (Floating-Point  Processor)  and  the  GT-XSD  and  GT-SEQ 
(crossbar  and  sequencer  boards),  as  well  as  updates  to  application  software  (the  Spinning  Missile 
simulation  and  EXOSIM). 
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2.  Hardware  and  Facilities 


This  section  begins  with  a  description  of  the  Parallel  Function  Processor,  including  recent 
changes,  and  then  discusses  the  current  configuration  of  the  two  alternative  host  computers. 
Most  of  the  detail,  though,  is  devoted  to  recent  improvements,  including  the  upgrade  from  286- 
based  processors  to  386-based  processors.  This  not  only  required  configuration  and  testing  of  the 
new  386-based  boards  (Intel  iSBC  386/12  boards),  but  also  modifications  to  the  attached 
crossbar  interface  board,  the  onboard  firmware,  and  the  Multibus  repeater  subsystem.  At  the 
same  time,  coprocessor  performance  was  enhanced  by  the  selection  of  the  Cyrix  device,  rather 
than  the  standard  Intel  80387,  but  some  compatibility  problems  were  found.  These  issues,  along 
with  current  board  status,  are  also  covered. 


2.1.  Parallel  Function  Processor  (PFP) 

The  Special-Purpose  Operational  Computing  Kernel,  or  SPOCK,  evolved  from  a  Ph.D. 
dissertation  (by  James  O.  Hamblen)  on  a  new  architecture  designed  to  solve  ballistic  missile 
simulations  Before  digital  computers  came  into  prominence,  some  of  these  simulations  had 
been  performed  quite  effectively  on  analog  computers,  in  which  basic  circuit  elements  are 
interconnected  by  a  patch  panel  to  create  an  approximation  to  the  real  system. 

Digital  computers  provided  the  potential  of  much  higher  accuracy  in  the  simulations,  but  at  the 
cost  of  speed:  most  real  systems  could  not  be  simulated  nearly  as  fast  as  they  really  run, 
generally  referred  to  as  real  time.  In  1978,  Georgia  Tech’s  SPOCK  I  addressed  the  problem  by 
showing  how  up  to  6  processors  could  effectively  perform  such  a  simulation. 

Building  on  the  previous  experience,  in  1982,  a  prototype  of  a  32-processor  system,  SPOCK  n, 
demonstrated  greater  capability  with  more-powerful  processors.  In  addition  to  the  digital 
processors,  SPOCK  II  also  had  analog  input  and  output  channels.  This  provided  the  important 
capability  of  interfacing  seamlessly  with  the  external  environment,  for  real-time  control  of  analog 
systems. 


Digital  Emulation  Technology  Laboratory  Final  Report 


8 


Since  that  time  we  have  developed  SPOCK  n  into  the  Parallel  Function  Processor  (PFP),  a  fully- 
operational  testbed  for  simulation  problems  from  both  military  and  nonmilitary  applications. 
The  architecture  never  stagnates  —  the  original  Intel  8086/8087  processors  were  each  roughly  as 
powerful  as  an  IBM  PC,  but  now  they  can  be  replaced  with  any  of  three  newer  processors.  One 
is  based  on  the  Intel  80286/80287  and  performs  as  well  as  an  IBM  AT.  Another  is  based  on  the 
Intel  80386/80387,  and  the  last  is  based  on  the  AMD  29325  and  is  about  25-100  times  faster  than 
the  other  processors  for  the  floating-point  calculations  which  it  is  designed  to  perform. 

All  of  the  processors  support  the  16-by-16  crossbar  interconnection,  allowing  each  to 
communicate  directly  with  the  others.  Multiple  conversations  may  take  place  simultaneously  on 
the  crossbar,  and  it  is  also  possible  for  a  single  processor  to  broadcast  data  to  every  other 
processor  in  a  single  instruction  cycle.  Since  the  crossbar  has  been  reduced  in  size  from  a  full 
19-inch  rack  down  to  a  cluster  of  eight  circuit  boards,  it  is  now  possible  to  have  the  power  of  32 
minicomputers  in  two  racks,  and  still  have  all  of  the  processors  work  together  efficiently. 

Each  of  the  current  processors  has  two  interfaces:  one  to  the  crossbar  for  data  communication 
while  running,  and  one  to  a  shared  bus  that  is  used  for  loading  programs  and  data  from  a  central 
host.  Virtually  any  imaginable  processor  can  be  fitted  to  a  processor  slot  in  the  PFP.  This 
includes  multiprocessors,  like  the  array  processors  described  earlier.  So,  if  an  image  processing 
problem  was  part  of  a  larger  simulation  problem,  it  could  be  assigned  to  an  array  processor 
within  the  PFP  system.  Co-processing  boards  have  been  developed  at  Georgia  Tech  that  evaluate 
complex  floating-point  functions  in  a  fraction  of  the  time  used  by  the  best  supercomputers  on  the 
market  today.  These  co-processing  boards  "piggy-back"  on  the  processors  described  earlier. 

Similarly,  a  complete  minicomputer  system  with  an  attached  3-D  graphics  workstation  has  been 
connected  to  one  of  the  PFP  processors,  thus  effectively  becoming  a  part  of  the  multiprocessor 
system.  This  allows  sophisticated  graphics  to  be  generated  in  real  time  as  the  simulations 
proceed. 

These  enhancements  demonstrate  that  other  architectures  can  be  applied  as  needed  within  the 
enveloping  PFP  architecture.  But  there  is  also  a  way  to  increase  the  PFP's  capability  at  a  higher 
level.  Since  the  number  of  processing  nodes  in  a  crossbar  is  practically  limited  because  of  the 
large  number  of  switches  required,  the  PFP  needs  a  way  to  grow  beyond  its  crossbar.  A  fully- 
operational  interconnection  board  has  been  developed  which  occupies  a  processor  node  in  a 
single  PFP  system.  When  a  processor  communicates  with  this  interconnection  board,  the  data  is 
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passed  out  over  an  external  channel  to  an  identical  board  in  another  complete  PFP.  By  adding 
more  interconnections,  multiple  PFPs  may  form  a  higher  level  of  parallel  processing.  A  triangle 
of  three  PFPs  still  allows  each  processor  to  communicate  with  any  other  processor  with  no 
intervening  processors,  although  there  may  be  some  waiting  for  an  available  channel. 

The  standard  configuration  of  the  PFP  at  this  time  is  a  64-processor  system  (2  crossbars), 
packaged  in  a  three-rack  system,  including  the  host.  A  single-crossbar  system  can  be  packaged 
in  two  smaller  racks,  if  desired.  A  64-processor  system  fitted  with  custom  interfaces  is  planned 
to  be  installed  at  Arnold  Engineering  Development  Center  in  Tennessee  to  support  simulation 
studies. 

Currently,  a  new  host  computer  for  the  PFP  is  being  developed,  based  on  the  Sun  386i.  This  new 
host  will  provide  enhanced  support  for  graphic  input  and  output,  and  it  is  now  serving  as  a 
platform  for  the  development  of  an  ADA  compiler  for  the  PFP. 

2.1.1.  Physical  Description 

The  full  64-node  PFP,  complete  with  the  host  computer,  occupies  three  19  inch  wide  by  32  inch 
deep  by  75  inch  high  equipment  racks.  Each  outer  rack  contains  32  PPE  slots.  The  center  rack 
contains  the  two  crossbars,  two  sequencers,  the  host  computer  and  two  crossbar  status  displays. 

All  processors,  as  well  as  the  sequencer,  conform  to  Intel's  Multibus  I  specification.  They  are 
connected  to  the  host  through  a  custom  Multibus  repeater  system,  which  is  used  by  the  host  to 
communicate  with  each  PPE.  Each  16  by  16  crossbar  switch  is  made  from  four  8  by  8  switch 
boards  connected  through  a  custom  backplane.  Each  8  by  8  switch  board  is  built  to  a  15.75  inch 
by  14.44  inch  Eurocard  standard.  Both  crossbars  are  housed  in  one  19  inch  wide  card  cage. 

Each  of  the  64  nodes  in  the  system  is  occupied  by  a  PPE.  A  PPE  can  be  one  of  five  different 
boards;  an  array  interconnect,  an  Intel  80286-based  commercially  available  processor,  an  Intel 
80386-based  commercially  available  processor,  a  Georgia  Tech  Floating-Point  Processor,  or  a 
multi-channel  analog  I/O  interface.  Other  boards  will  be  developed  as  necessary  to  enhance  the 
capability  of  the  PFP. 


Digital  Emulation  Technology  Laboratory  Final  Report 


10 


The  Georgia  Tech  Floating  Point  Processor  (GT-FPP/3)  is  an  8  MFLOP  computing  engine  based 
on  the  AMD  29325  floating  point  chip.  Currently,  the  board  is  programmed  using  a  subset  of 
Pascal.  An  ADA  compiler  is  in  development  for  use  with  this  processor. 

The  iSBC286/12  processor  is  commercially  built  by  the  Intel  corporation.  It  is  a  cheaper,  lower 
performance  board  than  the  GT-FPP/3.  The  board  is  useful  in  applications  that  require  large 
amounts  of  memory  such  as  table  look  ups.  Presently,  most  of  the  programming  is  done  in  Pascal 
or  PL/M,  although  FORTRAN,  C,  and  other  Intel  standard  utilities  are  available.  The  crossbar 
interface  to  this  board  is  built  to  fit  the  Intel  standard  iSBX  port  Supporting  other  Multibus  I 
processors  that  have  this  port  only  require  changes  in  the  board's  firmware.  The  iSBC386/12 
processor  is  an  80386-based  equivalent  of  the  iSBC286/12  board,  with  approximately  a  3-4  times 
speed  improvement  for  typical  PFP  applications. 

The  analog  input/output  board  consists  of  four  analog  to  digital  input  channels  and  four  digital  to 
analog  output  channels.  The  output  portion  consists  of  4  separate  digital  to  analog  converters. 
The  input  portion  consists  of  4  sample  and  hold  circuits  multiplexed  through  one  analog  to 
digital  converter.  Any  combination  of  inputs  and  outputs  are  available  for  use.  All  digital 
conversions  have  12  significant  bits. 

As  previously  mentioned,  the  array  interconnect  (GT-ARI/1)  is  used  as  a  direct  interconnect 
between  crossbars.  Each  array  interconnect  may  send  and  receive  16  bit  words  simultaneously 
from  other  array  interconnects. 

All  programs  are  written  and  compiled  on  the  host  computer  then  down  loaded  to  the  processors. 
Currently,  each  problem  is  analyzed  by  a  programmer  and  split  into  parts  which  are  then 
compiled  for  individual  processors.  A  separate  compiler  is  used  to  load  the  crossbar  and 
sequencer  with  the  instructions  for  processor  communication. 

The  major  components  of  a  full  system  are: 

1.  The  host  machine.  (This  may  be  an  Intel  310  or  Sun  386i) 

2.  An  MDB  Systems  Data  Shuttle  2000  removable  disk  drive  unit. 

3.  Up  to  64  processors  and  array  interconnects,  in  any  combination. 

4.  Up  to  two  sequencers. 
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5.  Up  to  two  full  16  by  16  GT-XB/2  crossbar  switches. 

6.  Up  to  two  GT-XSD/2  status  display  units. 

7.  Up  to  two  equipment  racks  containing  Multibus  I  card  cages,  sequencer  cabling, 

and  power  distribution. 

8.  One  equipment  rack  containing  the  crossbar,  sequencers,  crossbar  status  displays, 

and  appropriate  power  distribution. 

2.1.2.  Intel  310  Host 

The  Intel  310  host  is  based  on  a  12  Mhz  80286  processor  (actually  the  same  286/12  board 
available  for  use  in  the  PFP)  and  runs  the  Intel  iRMX  operating  system.  We  have  recently 
verified  that  it  is  possible  to  replace  the  host  286/12  board  with  a  386/12  board,  in  much  the 
same  way  that  we  have  replaced  the  PFP  286/12  processors  with  386/12  processors.  This 
configuration  can  execute  computationally-intensive  applications  (like  compilation  and  linking) 
about  four  times  faster  that  the  286-based  host.  The  host  is  tied  to  the  PFP  through  a  custom  set 
of  repeater  boards  developed  here  at  Georgia  Tech.  A  master  repeater  board  is  located  within  the 
host  chassis,  and  slave  repeater  boards  are  located  within  the  racks  of  processors.  The  machine 
supports  all  standard  Intel  languages  running  under  the  iRMX  operating  system,  including  C, 
Pascal,  PLM,  and  FORTRAN.  Programs  written  in  any  of  these  languages  may  be  compiled  and 
linked  on  the  host  and  then  downloaded  to  processor  boards  (iSBC  286/12s  or  iSBC  386/12s)  in 
the  PFP  for  execution.  In  addition,  the  host  supports  a  compiler  that  implements  a  subset  of 
Pascal  for  use  with  the  GT-FPP/3  custom  floating-point  processor. 

2.1.3.  Sun  386i  Host 

The  Sun  386i  host  is  based  on  a  25  Mhz  80386  processor  and  runs  the  Unix  operating  system.  It 
is  the  eventual  replacement  for  the  Intel  310,  leading  to  higher  performance  and  a  more  user- 
friendly  environment.  The  hardware  interface  to  the  PFP  is  similar  to  that  of  the  Intel  310  host, 
except  that  the  master  repeater  board  is  located  within  a  dedicated  Multibus  rack,  connected  to 
the  Sun  host  by  a  PC-to-Multibus  link.  (The  Sun  386i  utilizes  the  PC/AT  bus.)  A  C  compiler  is 
being  written  to  support  the  GT-FPP/3  processor,  and  other  languages  will  be  supported  via 
translators  (Ada-to-C  and  FORTRAN-to-C).  All  low-level  drivers  interfacing  the  Sun  to  the  PFP 
are  complete  and  several  small  Fortran,  Ada,  and  C  programs  have  been  loaded  and  tested. 
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Eventually,  the  Sun  will  also  support  standard  languages  for  programming  the  iSBC  386/12 
processors. 

2.1.4.  iSBC  386/12  Processor  Integration 

As  noted  earlier,  the  iSBC  386/12  processors  are  faster  replacements  for  the  iSBC  286/12 
processors.  The  integration  of  the  286/12  processors  was  completed  during  a  prior  year  of  this 
contract,  and  no  additional  developments  have  occurred  in  this  area.  The  386/12  processors, 
however,  were  integrated  mostly  over  the  period  of  early  1990.  This  involved  several  tasks, 
including: 

-  determination  of  proper  board  configuration, 

-  Multibus  repeater  modifications  to  support  expanded  address  space 

-  development  of  monitor  PROM  firmware, 

-  development  of  loader  software, 

-  testing  of  iSBX  crossbar  interface, 

-  re-layout  of  iSBX  crossbar  interface, 

-  testing,  debug,  and  workarounds  for  Cyrix  coprocessor,  and 

-  configuration  and  testing  of  full  complement  of  32  processors. 

It  was  during  the  integration  of  these  processors  into  the  system  that  we  decided  to  upgrade  our 
host  operating  system  from  RMX  I  to  RMX  II.  This  allowed  us  to  access  a  total  of  16 
Megabytes  of  memory  within  each  rack  of  processors  (at  least  1  Megabyte  per  processor).  It  also 
allowed  us  to  use  80286-based  and  80386-based  compilers  and  utilities  for  future  application 
development  on  the  PFP.  Most  of  this  development  that  occurred  under  the  RMX  n  host  is 
covered  in  the  other  final  report  for  the  Digital  Emulation  Technology  Laboratory,  which 
emphasizes  the  newer  tools  and  applications.  Because  of  the  transitional  nature  of  the  hardware 
and  firmware  modifications,  however,  they  are  covered  within  this  report. 


Digital  Emulation  Technology  Laboratory  Final  Report 


13 


2.1.4. 1.  iSBX  Crossbar  Interface  Boards 

One  major  factor  in  the  286-to-386  transition  was  the  usage  of  the  iSBX  Crossbar  Interface 
Board  (GT-XI286/2),  which  had  some  effect  on  several  of  the  items  listed  above.  The  earliest 
PFP  processors,  the  Intel  86/12  boards,  utilized  a  specialized  interface  to  the  crossbar  that 
plugged  into  a  ROM  socket.  In  the  interests  of  standardizing  on  an  interface  which  would  be 
ariaptahi*.  to  the  286/12  boards  and  follow-ons,  a  new  crossbar  interface  board  was  developed, 
based  on  the  standard  iSBX  interface.  This  standard  interface  was  established  by  Intel  and  is 
available  for  "piggy-back"  functionality  on  a  wide  range  of  Multibus  I  and  Multibus  n  processor 
boards. 

The  iSBX  I/O  Expansion  Bus  specification  is  equivalent  to  the  proposed  IEEE  standard  P959. 
Detailed  descriptions  may  be  found  in  Intel  product  data  books  and  in  the  Intel  publication  Intel 
iSBX  Bus  Specification  (manual  order  number  142686-001). 

Briefly,  the  iSBX  bus  supports  both  8-bit  and  16-bit  data  transfers  at  a  maximum  rate  of  1 
transfer  per  microsecond.  The  controlling  processor  board  generates  3  low-order  address  bits  and 
2  select  signals  (high  byte,  low  byte,  or  both),  allowing  the  attached  iSBX  board  to  contain  up  to 
16  addressable  bytes.  Typically,  these  blocks  are  defined  as  registers  which  are  offset  from  some 
base  I/O  address  in  the  processor's  address  space.  On  the  286/12,  the  GT-XI286/2  board 
generally  resides  at  base  address  80H  (in  the  I/O  space,  not  the  memory  space),  with  the  data 
register  at  80H/81H  and  the  status  register  at  82H/83H. 

The  GT-XI286/2  board  does  not  support  interrupts  or  DMA.  It  does  use  the  clock  signal  and 
reset  signal,  and  it  does  not  extend  the  transfer  cycle  through  the  use  of  MWAIT/.  The  GT- 
XI286/2  board  was  designed  according  to  the  physical  and  electrical  specifications  for  a  double¬ 
width  iSBX  board.  (The  specification  allows  for  two  sizes  of  boards,  and  we  required  the 
double-width  form-factor,  mainly  to  accomodate  ribbon-cable  connectors.)  Frequently,  processor 
boards  provide  two  iSBX  connectors,  allowing  the  user  to  attach  up  to  two  piggy-back  boards. 
This  was  the  case  with  the  286/12  board,  which  was  desirable  for  the  PFP  application,  since  it 
allowed  for  both  a  single-width  iSBX  board  (Tike  the  Georgia  Tech  Function  Board,  which 
evaluates  complex  arbitrary  functions  of  a  single  real  number),  as  well  as  the  double-width  GT- 
XI286/2  board. 
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Although  the  386/12  board  was  supposed  to  be  a  drop-in  replacement  (after  proper  configuration) 
for  the  286/12  board,  we  soon  encountered  a  major  discrepancy.  The  386/12  board  had  two 
iSBX  connectors,  but  it  was  only  possible  to  use  two  standard  iSBX  boards  if  both  were  single¬ 
width.  Since  the  GT-XI286/2  board  could  not  be  reduced  to  single  width,  it  was  redesigned  with 
a  non-standard  form-factor  that  avoids  the  memory  module. 

We  were  able  to  test  the  386/12s  with  the  original  iSBX  design  by  plugging  the  board  onto  the 
only  connector  which  accomodated  a  double-width  board.  This  merely  prevented  us  from  using 
the  Function  Board  or  any  other  iSBX  board  during  the  test  period.  Once  the  operation  was 
verified,  the  physical  layout  of  the  board  was  altered  by  Intel  at  no  charge,  as  partial 
compensation  for  what  we  perceived  as  a  design  flaw.  The  new  version  of  the  iSBX  Crossbar 
Interface  Board  is  part  number  GT-XI286/3. 

During  extended  testing,  we  discovered  intermittent  communication  errors  with  this  board.  The 
problem  was  eventually  traced  to  electrical  noise  due  to  inadequate  power  and  ground 
distribution.  The  board  had  been  designed  as  a  double-sided  board,  with  no  internal  planes  for 
power  and  ground.  Although  the  power  and  ground  traces  were  wider  than  signal  traces,  they 
were  apparently  not  sufficient.  We  were  able  to  repair  the  boards  by  adding  two  wires  to 
improve  distribution  along  the  long  axis  of  the  board.  All  boards  have  continued  to  perform 
satisfactorily  in  extended  testing.  Before  we  order  any  more  of  these  boards,  however,  we  will 
re-layout  the  board  with  internal  power  and  ground  planes. 

2. 1.4.2.  Board  Configuration 

The  board  configuration  consists  of  installing  EPROMs  (see  Monitor  Firmware  section), 
installing  a  coprocessor  (see  Cyrix  Coprocessor  section),  installing  the  iSBX  Crossbar  Interface 
board,  and  setting  jumpers.  The  386/12  boards  purchased  for  the  PFP  were  configured  with  one 
Megabyte  of  memory,  although  it  is  possible  to  use  more  memory  on  at  least  some  of  the 
processors.  The  default  jumper  settings  for  these  one-Megabyte  boards  are  suitable  as  a  starting 
point  for  configuration.  These  settings  are  listed  in  the  "iSBC  386/12  Hardware  Reference 
Manual,"  available  from  Intel. 

The  deviations  from  these  default  jumper  settings  are  as  follows: 

-  iSBX  DMA  is  disabled  (DMA  is  not  required). 
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-  PROM  size  is  256K, 

-  Dual-port  memory  is  set  to  allow  the  full  Megabyte  to  be  accessible  at  one  of  11 

locations,  depending  on  where  board  is  to  be  installed, 

-  Two  onboard  timers  are  cascaded, 

-  Onboard  processor  is  allowed  RAM  access  all  the  way  up  to  ROM  start  (no 

outward  Multibus  window), 

-  Coprocessor  is  enabled, 

-  Board  ID  code  changed  to  reflect  coprocessor  presence,  and 

-  iLBX  local  memory  bus  extension  is  disabled. 

2. 1.4.3.  Monitor  Firmware 

One  of  the  principle  reasons  that  we  made  the  switch  to  the  RMX  II  operating  system  and  the 
386/12  processor  boards  was  so  that  we  would  have  the  full  benefit  of  a  larger  working  memory 
space  on  each  target,  running  under  the  protected  mode  of  the  386  processors.  (This  would  have 
also  been  an  advantage  with  the  286/12  processors  which  we  had  been  using  for  some  time.) 
The  monitor  which  we  had  been  using  on  both  the  286/12  and  386/12  processors  supported  only 
the  real  mode  of  operation,  which  is  limited  to  an  emulation  of  the  simpler  8086  family  of 
processors,  with  little  capability  to  manage  and  control  memory  segments.  It  was  therefore 
necessary  to  develop  a  new  monitor. 

This  new  monitor  was  based  on  Intel's  iSDM  monitor,  which  is  available  as  Intel  product  number 
SDMSC,  version  3.2.  This  product  allows  a  user  to  begin  with  a  basic  monitor  which  can  be 
configured  for  a  custom  application  by  using  various  macro  calls.  It  also  allows  customized  user 
code  to  be  inserted  within  the  monitor,  which  was  necessary  for  our  application. 

Some  of  the  advantages  of  the  new  monitor  (and  protected-mode  operation)  include: 

-  greater  flexibility  in  choice  of  program  start  address, 

-  ability  to  create  specialized  buffers  for  host-processor  communication,  and 

-  automatic  creation  of  read-only  code  segments  and  multiple  data  segments 
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The  code  for  the  user-defined  section  of  the  monitor  firmware  is  included  in  Appendix  A. 

2. 1.4.4.  Multibus  Repeater  Modifications 

The  386/12  processors,  like  the  86/12s  and  286/12s  which  preceded  them,  provide  dual-port 
RAM  (memory  which  is  accessible  by  both  the  onboard  processor  and  any  bus  master  on  the 
Multibus).  In  the  PFP,  this  access  from  the  bus  is  needed  by  the  host  processor  and  its  associated 
Multibus  repeater  system.  The  Multibus  repeater  system  essentially  allows  multiple  Multibus 
card  cages  to  map  into  the  address  space  of  the  Multibus-based  host.  In  order  to  fully  utilize  the 
one  Megabyte  of  dual-port  RAM  on  the  386/12  processors,  it  was  necessary  to  modify  the 
repeater  system.  Previously,  it  was  only  possible  to  have  a  maximum  of  one  Megabyte  of 
memory  in  each  PFP  processor  rack,  and  this  had  to  be  split  up  among  the  processors  in  that 
rack.  Typically,  this  resulted  in  only  64K  or  128K  of  accessible  memory  on  each  processor, 
which  at  this  time  was  a  286/12. 

As  work  on  advanced  simulations  such  as  EXOSIM  proceeded,  this  memory  limitation  became 
critical.  Anytime  the  code  exceeded  64K,  a  special  loader  function  would  be  required  to  access 
the  additional  64K  on  those  boards  that  had  a  total  of  128K  available.  It  also  appeared  that  some 
of  the  partitioned  code  would  even  exceed  the  128K  limit.  Furthermore,  there  was  no 
straightforward  means  of  configuring  the  memory  on  the  newer  386/12  boards  to  map  only  64K 
or  128K  in  a  distinct  location  of  the  Multibus  address  space.  (This  was  another  unforeseen 
incompatibility  between  the  286/12  and  386/12  boards.)  The  solution  to  this  problem  was  to 
increase  the  dual-port  RAM  to  a  full  Megabyte. 

Modifications  were  made  to  PALs  on  the  286  processor  boards  and  on  the  slave  repeater  boards, 
and  some  wire  cuts  and  adds  were  made  on  the  slave  repeater  boards  as  well.  We  also  installed 
the  Multibus  "P2"  connector  on  the  card  cages  in  this  system.  This  connector  contained  only 
signals  which  were  never  required  in  previous  configurations  (at  one  point,  cables  were  routed 
out  of  the  backplane  at  the  P2  location).  The  uppermost  bus  address  lines,  needed  to  access  the 
full  16-Megabyte  address  space,  were  included  on  this  connector,  so  we  had  to  install  it  at  this 
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2. 1.4.5.  Cyrix  Coprocessor 

We  ran  into  some  unexpected  problems  when  we  attempted  to  run  some  applications  on  multiple 
target  processors  in  the  PFP.  Surprisingly,  we  were  unable  to  run  it  successfully  even  on  a  single 
target  processor.  The  problem  was  eventually  traced  to  the  Cyrix  math  coprocessor  chips  on  the 
386/12  boards.  These  are  supposed  to  be  direct  replacements  for  the  Intel  80387  chips,  but 
unexplained  errors  kept  coming  up.  Once  we  switched  back  to  the  Intel  chips,  the  program  ran 
normally.  We  wanted  to  use  the  Cyrix  chips,  since  we  could  get  a  performance  improvement  of 
up  to  20%  over  the  80387. 

We  received  the  most  current  revision  of  the  Cyrix  chips  and  tried  to  use  them,  but  we  found  no 
difference.  We  also  tried  the  Cyrix  chips  in  a  386  PC-compatible  machine,  also  running 
EXOSIM.  In  this  configuration,  we  had  no  errors.  Cyrix  also  sent  a  socket  adapter  with  a  built- 
in  PAL  that  fixes  a  problem  in  certain  configurations  (probably  in  certain  PC-compatibles).  We 
tested  this  fix,  too,  and  it  made  no  difference  in  our  application. 

We  continued  to  explore  the  apparent  incompatibilities  between  the  Cyrix  coprocessor  and  the 
80387  that  it  is  designed  to  replace  (with  a  performance  improvement  of  up  to  50%).  We  were 
eventually  able  to  trace  the  problem  to  a  misalignment  of  the  internal  stack  in  the  coprocessor. 
The  Intel  FORTRAN  compiler  generates  code  which  uses  reserved  (and  supposedly 
unimplemented)  80287/387  instructions.  These  instructions,  however,  are  actually  implemented 
in  the  80287  and  80387  hardware  as  redundant  ways  to  accomplish  the  same  effect  as  normal, 
documented  instructions.  Cyrix,  however,  did  not  emulate  these  reserved  instructions,  since  it 
should  not  have  been  necessary  to  do  so.  (The  Intel  compiler  generated  these  reserved  codes, 
when  it  should  have  generated  equivalent  functions  using  docutmented  instructions.)  The 
workaround  to  the  problem  is  to  always  turn  off  optimization  in  the  FORTRAN  compiler.  This 
prevents  the  unimplemented  instructions  from  ever  being  generated. 

The  five-processor  version  of  EXOSIM  (described  briefly  later  in  this  report)  was  .  recompiled 
using  the  new  compiler,  then  run  on  Cyrix-equipped  processors.  The  timing  results  are  given  in 
Table  1.  For  real-time  performance,  the  execution  time  for  each  partition  must  be  1.0  sec/real¬ 
time  sec  or  less.  This  particular  partitioning  was  an  early  attempt  and  does  not  represent  our  best 
effort  for  EXOSIM.  For  comparison,  the  same  partitioning  was  run  on  the  Intel  80387 
coprocessors,  and  the  results  are  given  in  Table  2. 


Table  1:  EXOSIM  five-processor  version  (new  compiler,  Cyrix  chips) 


Table  2:  EXOSIM  five-processor  version  (previous  compiler,  Intel  80387s) 


As  these  results  indicate,  performance  had  been  improved  by  up  to  46%  (but  only  23%  on  the 
"bottleneck"  partition).  We  continued  to  use  this  woricaround  to  avoid  further  problems  with  the 
Cyrix  coprocessor,  and  we  have  been  satisfied  with  the  improved  performance. 

2. 1.4.6.  Board  Testing  and  Status 

After  we  had  determined  a  satisfactory  configuration  for  the  386/12,  including  monitor, 
coprocessor,  dual-port  configuration,  and  iSBX  usage,  we  tested  a  limited  number  of  boards  in  a 
test  PFP  that  we  had  developed  specifically  for  that  purpose.  During  this  time,  we  had  only  five 
to  seven  386/12  boards  available,  but  this  was  sufficient  to  develop  test  software,  as  well  as  to 
experiment  with  some  simulation  applications.  By  the  time  we  were  satisfied  with  the 
performance  and  reliability  of  the  386/1 2s,  we  had  received  a  full  complement  of  32  boards. 

Each  of  these  boards  was  configured  and  tested,  then  subsequently  burned  in  for  millions  of 
crossbar  transfers.  Some  boards  failed  initial  testing,  and  others  failed  during  the  bum-in  period. 
These  were  returned  to  Intel  for  repair,  mostly  during  the  warranty  period.  The  current  status  of 
these  boards  is  given  in  Table  3.  The  "location"  column  gives  either  a  general  location,  such  as 
the  Intel  repair  facility  or  the  Sun  development  PFP,  or  a  specific  location  in  the  386-based  PFP. 
These  specific  locations  include  a  letter  and  a  hexadecimal  number.  The  letter  is  either  T,  M,  or 


Digital  Emulation  Technology  Laboratory  Final  Report 


19 


B,  for  Top,  Middle,  or  Bottom  rack.  The  hexadecimal  digit  is  the  base  address  page  of  the 
current  dual-port  memory  setting,  where  "8"  would  indicate  a  base  address  of  800000 
(hexadecimal). 
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Table  3:  386/12  Board  Status 


Serial  Number 

Order* 

Condition** 

Coprocessor 

Location 

N00209451 

1 

OK  ! 

Cyrix 

B2 

P00448691 

2 

OK 

Cyrix 

T6 

P00448744 

1 

OK 

Cyrix 

Sun 

P00466255 

3 

OK 

Cyrix 

T1 

P00466256 

3 

OK 

Cyrix 

Sun 

P00466258 

3 

OK 

Cyrix 

Sun 

P00466261 

3 

OK 

Cyrix 

M5 

P00466262 

2 

OK 

Cyrix 

T4 

P00466264 

3 

Failed  in  Sun 

Intel 

P00466357 

3 

OK 

Cyrix 

T2 

P00466358 

3 

OK 

Cyrix 

M9 

P00547569 

2 

Failed  in  PFP 

Intel 

P00568416 

3 

Failed  in  Sun 

' 

Intel 

P00568420 

3 

OK 

Cyrix 

M6 

P00568471 

3 

OK 

Cyrix 

T7 

P00592160 

3 

OK 

Cyrix 

M8 

P00593319 

2 

OK 

Cyrix 

B8 

P006 10398 

3 

OK 

Cyrix 

T9 

P006 10405 

2 

OK 

Cyrix 

T3 

P00610406 

2 

OK 

Cyrix 

T5 

P00610479 

2 

OK 

Cyrix 

Sun 

P00638698 

3 

OK 

Cyrix 

M3 

P00638699 

3 

OK 

Cyrix 

MA 

P00638700 

3 

OK 

Cyrix 

M7 

P00638702 

3 

OK 

Cyrix 

TB 

P00638703 

3 

OK 

Cyrix 

M2 

P00638704 

3 

DOA  twice  ! 

Intel 

P00638705 

3 

OK 

Cyrix 

B1 

P00638710 

3 

OK 

Cyrix 

TA 

P00638712 

3 

OK 

Cyrix 

B7 

P00638713 

3 

OK 

Cyrix 

M4 

P00638724 

3 

OK 

Cyrix 

MB 

P00641883 

3 

OK 

Cyrix 

T8 

P00641887 

3 

OK 

Cyrix 

Ml 

1-  First  two  boards  ordered  for  testing 

2  -  First  seven  boards  received  as  part  of  large  32-board  order 

3  -  Remainder  of  large  order 

**  OK  -  Memory,  crossbar  port,  coprocessor  all  checked  out 
Failed  -  Initially  OK,  but  subsequently  failed 
DOA  -  Failed  initial  testing 
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2.2.  Seeker  Scene  Emulator  (SSE) 

In  addition  to  developing  crossbar  machines  like  the  PFP,  we  are  actively  studying  other 
architectures,  since  there  is  no  such  thing  as  a  completely  general-purpose  parallel  computer. 
One  of  the  most  promising  is  a  group  of  architectures  built  around  a  new  microprocessor  chip, 
the  Inmos  Transputer.  Unlike  previous  microprocessors,  the  Transputer  was  specifically 
{fc»signp/t  to  be  interconnected  with  others  of  its  kind.  Since  a  single  chip  includes  the  processor, 
memory,  and  communication  ports,  it  is  possible  to  build  a  parallel  machine  with  little  more  than 
a  group  of  Transputers. 

Each  Transputer  has  four  links  that  can  be  used  to  tie  them  together,  allowing  a  wide  range  of 
architectures  to  be  built.  One  of  our  principal  applications  for  the  Transputer  is  a  Seeker  Scene 
Emulator,  a  machine  that  models  what  an  imaging  sensor  on  a  missile  would  see  during  a 
mission.  Most  simulations  of  such  systems  tend  to  simplify  the  infrared  sensing  process  in  order 
to  minimize  computations,  but  the  Georgia  Tech  Seeker  Scene  Emulator  will  provide  a  signal 
which  can  be  displayed  on  a  screen  and  will  look  virtually  identical  to  a  real  view  of  an  incoming 
threat 

This  seeker  output  can  then  be  used  by  a  simulation  running  on  the  PFP,  or  by  an  actual  guidance 
and  control  processor,  like  the  one  being  developed  for  our  VLSI  devices.  The  Seeker  Scene 
Emulator  will  use  256  Transputers,  so  when  connected  to  PFP  in  a  simulation,  it  will  be  another 
example  of  a  specialized  parallel  processor  within  the  more  general  crossbar  architecture  of  PFP. 

Under  direction  from  the  U.  S.  Army  Strategic  Defense  Command,  the  Computer  Engineering 
and  Research  Laboratory  at  the  Georgia  Institute  of  Technology  and  BDM  Corporation  are 
developing  a  real-time  Focal  Plane  Array  Seeker  Scene  Emulator.  This  unit  will  enhance 
Georgia  Tech's  capabilities  in  KEW  system  testing  and  performance  demonstration. 

The  FPA  Seeker  Scene  Emulator  combines  advanced  hardware  developed  at  Georgia  Tech  with  a 
BDM-generated  database  to  produce  signals  based  upon  target  radiometric  information,  seeker 
optical  characterization,  FPA  detector  characterization,  and  simulated  background  environments. 
Using  real-time,  positional  updates,  typically  from  the  Georgia  Tech  Parallel  Function  Processor, 
the  Seeker  Scene  Emulator  can  combine  elements  of  the  pre-computed  database  to  foim  an  image 
that  is  positionally  and  radiometrically  correct. 
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In  conjunction  with  development  of  the  FPA  Seeker  Scene  Emulator,  research  into  signal 
processing  of  seeker  data  is  underway.  The  Seeker  Scene  Emulator  provides  a  platform  for  the 
expedient  testing  of  algorithms  and  implementations.  Currently,  a  parallel-processing  network  is 
being  used  to  test  various  signal  processing  "building  blocks." 

Detailed  information  about  the  Seeker  Scene  Emulator  may  be  found  in  a  separate  final  report. 


2.3.  Other  computer  systems 

Currently  a  Digital  Equipment  Corporation  MicroVax  II  is  used  as  the  primary  file  server  for  the 
Seeker  Scene  Emulator.  This  system  is  equipped  with  a  nine-track  tape  system,  a  high-density 
EXABYTE  tape  cartridge  unit,  the  standard  TK50  tape  unit,  an  Ethernet  network  interface,  and  a 
Caplin  Cybernetics  Corporation  QTO  Transputer  Interface  Module.  Using  the  Transputer 
Interface  Module,  the  target  and  noise  data  files  are  transferred  directly  to  the  processors  of  the 
Seeker  Scene  Emulator  at  rates  of  800  kilobytes  per  second. 

This  same  MicroVax  is  used  as  the  primary  means  of  transferring  programs  and  data  to  and  from 
other  contractors.  Programs  written  for  Vaxes  and  other  off-site  computers  may  be  loaded  onto 
this  MicroVax  via  its  nine-track  tape  drive.  From  there,  files  may  be  transferred  to  the  PFP  hosts 
(Intel  310s  or  Sun  386i's)  or  to  other  computer  systems.  Also,  additional  simulation  support  is 
available  on  this  system  through  the  MatrixX  and  ACSL  languages.  Both  languages  provide  an 
environment  for  the  simulation  of  discrete  and  continuous-time  systems,  including  a  choice  of 
integration  methods.  MatrixX  also  has  a  graphical  user  interface  for  entering  simulation 
specifics.  This  MicroVax  is  approved  for  classified  data  processing. 

Another  MicroVax  is  dedicated  to  a  Chromatics  3-D  graphics  workstation.  This  combination  of 
machines  may  be  directly  connected  to  a  PIT  processor  in  order  to  display  complex  three- 
dimensional  graphics  during  simulations.  Both  of  these  machines  are  approved  for  classified 
data  processing. 
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2.4.  Secure  laboratory 

The  principal  elements  of  the  Digital  Emulation  Technology  Laboratory  are  housed  in  a 
laboratory  on  the  third  floor  of  the  Centennial  Research  Building  which  has  been  approved  for 
classified  operation  up  to  the  secret  level.  Within  this  facility  are  most  of  the  machines  which 
have  been  described,  including: 

-  the  80386-based  PFP,  with  FPP  capability, 

-  two  PFP  host  machines  (Intel  310s), 

-  the  Seeker  Scene  Emulator, 

-  the  MicroVax  with  9-track  and  EXABYTE  tape  drives, 

-  the  Micro V ax/Chromatics  system,  and 

-  an  IBM-compatible  PC,  primarily  for  classified  word  processing. 

Each  of  these  machines  is  approved  for  classified  processing.  The  two  PFP  host  machines  are 
functionally  identical,  with  one  always  available  as  a  backup.  A  safe  is  also  provided  for  storage 
of  classified  documents  and  magnetic  media.  All  hard  disks  on  classified  machines  are 
removable,  and  the  classified  operating  disks  are  stored  in  the  safe. 
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3.  System  Software 

This  chapter  covers  the  latest  changes  which  have  been  made  to  system  software  which  supports 
the  Floating-Point  Processor  (FPP)  and  the  Crossbar/Sequencer  subsystem.  These  changes 
represent  incremental  improvements  and  corrections  that  were  required  to  make  these  tools 
operate  within  the  current  PFP.  Not  covered  here  are  the  completely  new  versions  of  system 
software  which  were  developed  for  the  new  RMXII-based  host.  This  effort  is  documented  in  the 
other  DETL  final  report  for  this  past  year. 

3.1.  Floating-Point  Processor 

Significant  updates  have  been  made  to  both  the  Floating-Point  Processor  (FPP)  Loader  and  the 
FPP  Compiler,  running  under  the  iRMX  n  operating  system.  These  are  described  in  the  next  two 
sections. 

3.1.1.  Compiler 

The  PFP  floating  point  processor  compiler  supports  a  subset  of  Pascal.  Data  types  supported 
include  32  bit  real,  32  bit  integer,  and  arrays.  The  compiler  recognizes  FOR-DO,  WHILE-DO, 
IF-THEN-ELSE,  and  BEGIN-END  constructs.  Any  arbitrary  arithmetic  and  boolean  expressions 
are  allowed.  In  addition,  the  compiler  supports  procedures  and  functions  with  arbitrary  number 
of  call-by-value  and  call-by-reference  parameters. 

The  Pascal  compiler  was  designed  to  produce  efficient  code  for  the  PFP  floating  point  processor 
without  the  generation  of  any  intermediate  code.  Instead,  the  compiler  directly  maps  the  high 
level  language  expressions  into  executable  machine  code. 

The  Pascal  compiler  was  originally  written  in  Pascal  and  tested  on  a  PC/AT  system.  The 
operating  system  dependent  portions  of  the  Pascal  compiler  were  rewritten  and  then  recompiled 
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and  tested  on  the  iRMX  n  system.  The  source  code  for  the  compiler  may  be  found  in  Appendix 

B. 

3.1.2.  Loader 

The  PFP  floating  point  processor  loader  supports  the  output  of  the  Pascal  compiler.  The  loader 
takes  the  output  of  the  Pascal  compiler  and  downloads  code  and  data  into  the  target  floating  point 
processor.  The  loader  requires  six  steps: 

1.  Download  a  bootstrap  program. 

2.  Start  the  bootstrap  program. 

3.  Send  application  program  data  to  the  bootstrap  program. 

4.  Stop  the  bootstrap  program. 

5.  Download  the  application  program  code. 

6.  Start  the  application  program. 

The  loader  was  originally  written  in  Pascal  and  tested  on  a  PC/AT  system.  The  loader  was 
rewritten  in  C  and  then  recompiled  and  tested  for  the  iRMX  n  system.  The  source  code  for  the 
loader  may  be  found  in  Appendix  C. 


3.2.  Crossbar  and  Sequencer  Compiler 

In  order  to  execute  a  parallel  program  on  the  PFP,  crossbar  and  sequencer  code  is  needed  to 
describe  the  required  communications.  The  compiler  reads  a  simple  language  which  describes 
the  communications  and  generates  three  output  files.  One  output  file  contains  the 
communications  and  indicates  the  condition  of  the  status  lights  during  a  simulation,  this  is  useful 
for  debugging.  If  the  compiler  detects  an  error  in  the  input  file,  an  error  message  will  be  placed 
in  this  output  file  and  the  compiler  will  stop.  The  remaining  two  output  files  contains  the 
absolute  code  for  the  sequencer  and  crossbar  for  the  particular  simulation.  The  sequencer 
absolute  code  is  generated  as  the  compiler  reads  the  input  file,  whereas  the  crossbar  absolute  code 


is  generated  after  the  compiler  has  read  the  entire  input  file.  To  use  the  crossbar  memory 
efficiently  the  same  switch  pattern  can  repeatedly  be  used,  thus  reducing  the  crossbar  memory 
requirements.  This  is  accomplished  by  reusing  the  next  crossbar  address  in  the  sequencer  code. 
These  two  absolute  files  can  be  directly  loaded  to  the  sequencer  and  crossbar  without  any 
intermediate  steps. 

The  compiler  was  originally  written  in  Pascal  and  tested  on  a  iRMX  I  hosted  PFP  system.  The 
compiler  was  modified  and  then  recompiled  and  tested  on  a  iRMX  n  hosted  PFP  system. 
Modifications  include  changing  the  absolute  code  format  to  conform  to  the  iRMX  n  absolute 
code  format.  Also,  the  language  used  to  describe  the  communications  was  enhanced  so  as  to 
allow  for  two  distinct  crossbars  and  sequencers  per  host  system.  The  source  code  for  the  compiler 
may  be  found  in  Appendix  D. 
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4.  Application  Software 


During  the  past  contract  year,  most  of  the  programming  effort  has  focused  on  system  software, 
but  some  major  developments  have  also  occurred  with  application  software.  This  chapter 
describes  both  the  Spinning  Missile  simulation  and  the  preliminary  KWEST/EXOSIM  activity. 


4. 1 .  Spinning  Missile 

The  Spinning  Missile  problem  is  a  benchmark  used  by  Electronic  Associates,  Inc.  It  had  already 
been  implemented  on  earlier  versions  of  the  PFP,  but  it  was  recently  ported  to  the  286-based  and 
386-based  PFPs  with  their  new  complement  of  system  software.  The  problem  is  a  six-degree-of- 
freedom  missile  represented  by  eighteen  states.  The  equations  of  motion  for  the  missile  are 
given  in  Figure  4.1. 


u'  =  r  v  -  q  w  +  (l/m)[T  -  l/2p(u  +  W  )2ACD  ]  -  gsinO’ 

SS3  SS  S  X  O 

v’s  =  -rA  +  (l/m)[-l/2pu  ACNa(v  -  Wy)  +  F^] 

w’  =  q  u  +  (l/m)[-l/2pu  AC  (w  +  W  )  -  F  1  +  gcosO' 

3  S  S  S  Nfl  S  Z  iX 

P’s  =  (lAxs)[-l/4pu  AD2Cu>Ps  +  l/2pu  2ADCU  dt  +  Lt  +  D  pj. 
q'  =  (1/1  )[l/2pu  ADC  (w  +  W  )  +  l/4pu  AD2C  q 

s  ys  s  ma  s  z  s  mq  s 

-(Lc  -  lcg^fiz  ’  rspsy 

f  =  (1/1  )[-l/2pu  ADC  (v  -  W  )  +  l/4pu  AD2C  r 

s  ys  s  ma  s  y  s  mq  s 

-(VLOG)FTY  +  P,<!,IJ 


Figure  4.1  Spinning  Missile  equations  of  motion 

The  missile  model  was  originally  programmed  in  ACSL  on  a  PC,  to  have  a  standard  to  compare 
the  PFP  results  with.  The  problem  was  then  partitioned  onto  thirty-two  processors  in  the  PFP. 
Eighteen  of  the  processors  are  used  to  integrate  the  states  and  the  remaining  fourteen  are  used  to 
calculate  table  values  based  on  time  or  state  values.  These  tables  represent  atmospheric  density, 
wind  coordinates,  aerodynamic  coefficients,  spin  torque,  thrust,  control  force  moment  arm, 
missile  mass  and  moment  of  inertia.  All  interpolation  is  linear. 

The  PFP  with  80286  based  processors  (Intel  iSBC  286/12)  were  used  to  time  the  simulation.  For 
a  0.5  millisecond  integration  step  size  (fourth  order  Runge-Kutta),  the  PFP  takes  10.23 
milliseconds  for  an  equivalent  time  step.  Real-time  performance  was  not  expected  using  the 
286/12  processor.  Analysis  of  computational  and  communication  loads  for  this  problem  yields 
real-time  performance  if  the  GT-FPP/3  (high  speed  processor)  is  substituted  for  the  286/12 
processor. 
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The  missile  model,  which  was  originally  partitioned  into  thirty-two  Pascal  programs  and  tested 
on  a  iRMX  I  hosted  PFP  system,  was  modified  and  then  recompiled  on  a  iRMX  II  hosted  PFP 
system.  The  missile  simulation  was  then  rerun  as  verification  that  the  iRMX  n  system  and  its 
associated  development  tools  produced  the  same  results  as  the  iRMX  I  system.  The  source  code 
for  the  missile  model  may  be  found  in  Appendix  E. 


4.2.  KWEST/EXOSIM 

As  noted  earlier,  the  implementation  of  EXOSIM  is  an  ongoing  effort  and  is  described  in  a 
separate  final  report.  In  the  context  of  this  contract,  EXOSIM  is  the  culmination  of  a  series  of 
exoatmospheric  simulations,  as  shown  in  Figure  4.2.  In  this  section  we  will  provide  a  brief 
overview  of  the  activity  which  has  led  up  to  the  current  project  in  which  we  are  attempting  to 
fully  parallelize  EXOSIM. 
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Figure  4.2:  Evolution  of  EXOSIM 


ERIS  Baseline  Specifications  -  LMSC 

KWEST  Simulation  -  BDM 
ACSL/FORTRAN 

KEERIS  Simulation  -  CRC  (10/88-2/89) 

Boost-phase  only 
ACSL/FORTRAN 

EXOSIM  Version  1.0  Simulation-  CRC  (3/89-6/89) 
Post-boost,  midcourse,  KV  phases  modeled 
All-FORTRAN 
BDM  staring  FPA  seeker 

EXOSIM  Version  2.0  Simulation-  CRC  (7/89-10/89) 
Enhanced  seeker,  IMU 
SP/OP  algorithms  added 

Modifications  to  midcourse  guidance  and  attitude  control 
All-FORTRAN 

Unclassified  EXOSIM  -  Dynetics  (1/90-5/90) 

Based  on  Version  1.0 

First-  and  second-stage  boost  only 

Time-driven,  not  event-driven 

Commented  for  parallel  partitioning  (up  to  five  processors) 

Parallel  EXOSIM  -  Georgia  Tech  (3/90-present) 

Based  on  Unclassified  EXOSIM 
Partitioned  for  up  to  27  processors 
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The  KWEST  simulation  is  still  being  used  indirectly  at  DETL.  The  data  files  used  by  the  Seeker 
Scene  Emulator  are  generated  partly  by  a  version  of  KWEST  running  at  BDM.  This  activity  is 
described  in  the  final  report  on  the  Seeker  Scene  Emulator.  Also,  KWEST  is  being  used  as  a 
basis  for  a  6DOF  simulation  written  entirely  in  C,  with  the  intent  of  porting  it  to  a  PFP  populated 
with  Georgia  Tech  Floating-Point  Processors.  This  activity,  too,  is  described  elsewhere. 

As  we  considered  a  candidate  simulation  for  the  PFP,  Version  1.0  of  EXOSIM  was  not 
considered  promising  for  parallel  implementation  because  of  its  inherent  event-driven  structure. 
We  received  some  assistance  from  a  subcontractor  (Dynetics)  in  converting  EXOSIM  1.0  to  an 
unclassified,  time-driven  version.  Although  this  unclassified  EXOSIM  was  developed  and  tested 
on  a  single-processor  system,  parallel  partitions  were  identified  with  inline  comments.  These 
partitions  were  tested  by  shuffling  them  within  the  main  loop  of  the  program. 

The  result  of  this  was  that  it  was  relatively  easy  to  port  the  simulation  to  the  PFP  (about  1  day). 
There  were  some  uninitialized  variables  and  a  few  minor  deviations  from  ANSI  FORTRAN 
(excessive  continuation  lines,  do  loops,  and  nonstandard  initialization  of  common-block 


variables),  but  the  basic  porting  process  was  reasonably  straightforward,  unlike  many  earlier 
simulations  which  required  a  great  deal  of  manual  effort. 

The  current  status  of  EXOSIM  is  given  in  Figure  4.3. 
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Figure  4.3:  Current  Status  of  EXOSIM  at  DETL 


Dynetics  versions 

4-processor  and  5-processor  versions  both  running  on  PFP 
Demonstrated  feasibility  of  expressing  parallelism  in  commented  single- 
processor  code 

Pre-tested  code  ported  easily  to  PFP 
Did  not  fully  exploit  parallelism 

GT  parallel  versions 

Developed  in  stages  by  restructuring,  offloading  table  lookups,  optimizing 
communication  timing,  predicting  values,  and  minimizing  double  precision 
Running  first  on  KDEC  (286-based)  PFP,  then  recently  ported  to 
development  (386-based)  PFP 

Further  improvements  will  concentrate  on  minimizing  communication  time 
and  achieving  real-time  performance 


Appendices 
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A.  Monitor  source  code 

Copyright  1990 

Georgia  Tech  Research  Corporation 
Centennial  Research  Building 
Atlanta,  GA  30332 

custom:  do; 

declare  interrupt_number  word  public; 

custom:  procedure  public; 

interrupt_number  -  0; 


call 

setw( 

OOOOOH,  build $ptr( 

selector ( 

OOOOOH  ) 

,  01000H  ) 

,  07800H 

) ; 

call 

setw( 

OOOOOH,  build$ptr( 

selector ( 

01000H  ) 

,  OOOOOH  ) 

,  08000H 

) ; 

call 

setv( 

OOOOOH,  build$ptr( 

selector { 

02000H  ) 

,  OOOOOH  ) 

,  08000H 

) ; 

call 

setw( 

OOOOOH,  build$ptr< 

selector { 

03000H  ) 

,  OOOOOH  ) 

,  08000H 

>; 

call 

setw( 

OOOOOH,  build$ptr( 

selector ( 

04000H  ) 

,  OOOOOH  ) 

,  08000H 

) ; 

call 

setw  ( 

OOOOOH,  build$ptr< 

selector ( 

05000H  ) 

,  OOOOOH  ) 

,  08000H 

); 

call 

setw( 

OOOOOH,  build$ptr ( 

selector { 

06000H  ) 

,  OOOOOH  ) 

,  08000H 

)  ; 

call 

setw( 

OOOOOH,  build$ptr< 

selector ( 

07000H  ) 

,  OOOOOH  ) 

,  08000H 

) ; 

call 

setw( 

OOOOOH,  build$ptr ( 

selector ( 

08000H  ) 

,  OOOOOH  ) 

,  08000H 

)  ? 

call 

setw( 

OOOOOH,  build$ptr( 

selector  < 

09000H  ) 

,  OOOOOH  ) 

,  08000H 

) ; 

call 

setw  ( 

OOOOOH,  build$ptr( 

selector { 

OaOOOH  ) 

,  OOOOOH  ) 

,  08000H 

)  t 

call 

setw( 

OOOOOH,  build$ptr ( 

selector { 

ObOOOH  ) 

,  OOOOOH  ) 

,  OdOOOH 

) ; 

call 

setw( 

OOOOOH,  build$ptr( 

selector ( 

OcOOOH  ) 

,  OOOOOH  ) 

,  08000H 

>; 

call 

setw  { 

OOOOOH,  build$ptr ( 

selector ( 

OdOOOH  ) 

,  OOOOOH  ) 

,  08000H 

)  ; 

call 

setw( 

OOOOOH,  build$ptr{ 

selector ( 

OeOOOH  ) 

,  OOOOOH  ) 

,  08000H 

>; 

do  while  (  interrupt_number  -  0  ) ; 
end; 

if  {  interrupt_number  -  32  ) 
then 

cause$interrupt (  32  ) ; 


cause$interrupt (  3  ); 
end  custom; 


end  custom; 
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B.  Floating-Point  Compiler  source  code 


Copyright  1990 

Georgia  Tech  Research  Corporation 
Centennial  Research  Building 
Atlanta,  GA  30332 

File:  ADDRJ5EN.PAS 
program  addr^gen; 
const 

mbus_window  —  $d000; 
multibu3_segment  -  $09; 

var 

program_counter  :  integer; 

branch_opcode,  am2910_opcode,  branch_address  :  integer; 
infile  :  text; 
infilename  :  string [521; 

memory^ bank,  segment,  i,  offset  :  integer; 
word  :  array[0..5]  of  integer: 

begin 

segment  mbus_window; 

writeln  (*  -Multibus  adapter  card  is  set  to  64k  window  at  $0D0000  ' ); 
off sett  port [$200]; 

writeln  {'  -multibus  page  register  is  set  st  IO  address  $202*); 
port [$200]  raultibus_segment; 

writeln  (’  -Multibus  page  is  set  at  $09  where  fpp  memory  is  mapped'); 

memw ( segment :$f 000]  0; 

writeln ('  -  AMD  processor  is  halted’); 

branch_opcode  $c; 

am2910_opcode  $0 

writeln  (’input  file  :  readln ( inf ilrname ) ; 

if  infilename  -  ’’  then  infilename  ’branchop . in ’ ; 

reset (infile,  infilenarae) ; 
readln  (unfile) ; 
program_counter  0; 
while  not  eof  (infile)  do 
begin 

readln  (infile,  prograra_counter,  am2910_opcode,  branch_address) ; 
branch_address  (branchy address  and  $ccc)  + 

(word  shr (word_and  (branch_address,  $002  ),  1))  + 

(word  shl(word_and  (branch_address,  $001  ),  1))  + 

(word  shr (word_and  (branch_address,  $020  ),  1))  + 

(word  shl(word_and  (branch_address,  $010  ),  1))  + 


Digital  Emulation  Technology  Laboratory  Final  Report 


36 


(word_shr (word_and  (branch_address,  $200  ),  1))  + 
(word__shl (word^and  (branch_address,  $100  ),  1)); 
word[4]  s-  word_ahl  (branch__opcode,  12); 

word(5]  word_shl  (am291Q_opcode,  12)  +  (branch_address) ; 
for  memory_bank  4  to  5  do 

memw{word_or  {segment,  word_shl  {raemory_bank,  9) : 
word_shl  (program_counter,  1)  ]  word  [memory_ban]c] ; 

end; 


writeln  {; address  generator  program  is  down  loaded.’) 
end. 
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File:  ARITH.DEF 
public  arith; 

Procedure  create_index_terra; 

Procedure  index_expression {evaluate : boolean) ; 

Procedure  index_constant_terra (evaluate  :  boolean); 

Procedure  index_integer (evaluate  :  boolean); 

Procedure  Boolean_expression; 
procedure  arithmetic_term; 

procedure  standard_function_call (var  fx  s  operand_type) ; 
Procedure  unary _arithraetic_expression; 

Procedure  arithmetic_constant; 

Procedure  simple^ arithraetic^expression; 

Procedure  arithmetic^ expression; 

Procedure  compound_arithmet ic_expr e s s i on ; 

Procedure  index_assignment_statement; 

Procedure  general_expression(head_operand  :  operand_type) ; 
Procedure  assignraent_stateraent; 

Procedure  procedure_call; 

Procedure  funetion_call (var  fx  :  operand_type) ; 

Procedure  fetch_parameter (var  parameter  :  operand_type) ; 
Procedure  fetch_assignedjpararaeter (parameter  :  operand_type) ; 
Procedure  fetch_index(var  index  :  operand_type) ; 
procedure  fetch_operand(var  operand  :  operand_type) ; 
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File:  ARITH. PAS 
module  arith; 

$ include (arith . def ) 

$ include { global. def) 

$ include (expraion.def) 

$include ( exprtree.de f) 

$include (utility .def) 

$include ( f etch_tk . def ) 

$include { symbol_t .def) 

$include ( code_gen . def) 

$include (declare . def) 

$include ( lib . def ) 

^include (emu^lib.def ) 
private  arith; 

Procedure  create_index_term; 
begin 

create_expresaion (new_expression) ; 

laat_expression(expression_level] *.down  new_expre33ion; 
new_expresaion*.up  last^expresaiontexpression^level] ; 

last_expression [expression_level]  new_expression; 
aasign_percent_variable  (token) ; 
last_expresaion (expreaaion_level) * .  id  token; 

laat_expre33ion(expresaion_levell ,,‘.id_type  integer_aymbol_type; 
last_expresaion[expression_level) A. operator  unary_index; 
create_expreaaion (new_expreaaion) ; 

last_expreaaion [expreaaion_level 1  * . down  : -  new_expreaaion ; 
new— expression* .up  last_expression [expreasion_level] ; 

last_expres3ion[expression_level]  new_expression; 
end;  {  of  create_index_term  ) 

Procedure  index_constant_term< evaluate  :  boolean); 
var  operandl  :  token_type; 

operandl_value  ;  longint; 
child_expreaaion  :  expressionjjointer; 
operand  :  operand_type; 
begin 

operandl  token; 

operand l_value  integer_constant_value; 

fetch^token; 

if  token  -  multiply_token  then 
begin 

child__expression  last_expreasion{expression_level] ; 

if  not  evaluate  then  la3t_expression [expression_level]  :«  last_expression [expression_level] * . left; 

create_index_terra; 

if  operandl_value  <  0  then 

begin 

token  blank_token; 

token (1] 

concat (token, operandl) 

end 


else  token  operandl; 
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aymbol_type  integer__constant_aymbol_type; 
find_symbol  (token,  syrabol_type,  symbol_value,  found)  ; 
if  not  found  then 
begin 

insert_syrnbol  (token,  symbol_type ,  syinbol_value)  ; 
declare_constant  <symbol__value,  symbol_type,  token)  ; 
end; 

operand. id  token; 

operand . id_type  integer_syrabol__type; 
operand. index  blank_token; 
operand. off set  0; 

insert_sibling_expression<operand, null_operator) ; 
expression_operator [expression_level]  s ■  multiplication; 
fetch_token; 

compound_arithmetic_expression; 

delete_expreaaion(last_expresaion texpreasion_levelJ ) ; 

if  evaluate  then 
begin 

t raver  se_expres  siontree ; 
end 
else 
begin 

last_expression[expression_levelJ  child__expression; 
end; 
end 
else 
begin 

if  evaluate  then 

last  expression (expression_level] - .offset  s-  last_expression [expression_level] * . offset  +  operandl_value 
else 

last_expression [expression_level] - . left- .offset  i -  last_expression [expression_level] - . left- . offset  + 
oper andl_value ; 
end ; 

end;  {  of  index_constant_tem  ) 

Procedure  index_integer (evaluate  :  boolean); 
label  1;  {  constant  } 

var  child_expression  :  expression_pointer; 
operandl, operand2  :  token_type; 
operand2_value  :  longint; 
operand2_symbol_type  :  longint; 
operator 1  :  token_type; 
begin 

operandl  token; 
fetch_token; 

if  {token  -  plu3_token)  or  (token  -  minus_token)  then 
begin 

1  (  constant  } : 
operator 1  token; 

fetch__token; 

find_symbol (token, symbol_type, symbol_value,  found) ; 
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if  (not  found)  and  <syrabol_type  -  integer_constant__symbol_type)  then 
begin 

insert_symbol (token, syrabol_type, syrabol^value) ; 
declare_constant (symbol^value, symbol_type,  token) ; 
end; 

operand2  token; 

operand2_value  integer_constant_value; 
operand2_symbol_type  symbol_type; 

if  symbol_type  -  integer_constant_symbol_type  then 
begin 

fetch_token; 

if  token  -  multiply_token  then 
begin 

child_expression  last_expression[expression_level) ; 

if  not  evaluate  then  last_expre3sion(expre3sion_level]  last_expressian(expres3ion_level] A .left; 

create_index_terra; 

operand. id  operandl; 

operand . id_type  2 -  int eger_syrabol_type ; 

operand. index  blanket oken; 

operand. off set  0; 

insert_sibling_expre3sion (operand, null_operator ) ; 
if  operatorl  -  plus_token  then 

expression_operator [expression_level]  addition 

else 

expression_operator [expreasion_level]  subtraction; 

operand. id  operand2; 

operand . id_type  integer_constant_symbol_type; 

operand. index  blank_token; 
operand. offset  0; 

insert_sibling_expression (operand, expression_operator(expression_level] ) ; 

expression_operator [expression_level]  multiplication; 

fetch_token; 

corapound_arithmetic_expre3sion ; 

delete_expression(last_expression(expression_levell ) ; 

if  evaluate  then 

begin 

traverse_expre3sion_tree; 

end 

else 

begin 

last_expres3ion(expression_level]  child_expression; 
end; 
end 
else 
begin 

if  evaluate  then 
begin 

if  operatorl  -  plus_token  then 

last_expression [expression_level] * . of fset  last_expression [expression_level] A .offset  +  operand2_value 

else 

last_expression [expres3ion_levell ~ . offset  2-  last_expression(expression_levelJ A .offset  -  operand2_value; 


Digital  Emulation  Technology  Laboratory  Final  Report 


41 


end 

else 

begin 

if  operatorl  -  plus_token  then 

last_expression [expression_level] * .left* .offset 
la»t_expression [expression^JLevel] * . left* .off set+operand2_value 
else 

last_expression [expression_level] * .left* .of fset  last_expression [expression_level] * . left* . off set- 

operand2_value 

end: 

if  (token  -  plus_token)  or  (token  -  minus_token)  then  goto  1; 

if  token  -  close_square_bracket  then 

begin 

if  evaluate  then 

last  expression texpression_level] *. index  operandl 
else 

last_expression{expression_level]*. left*. index  operandl; 

end; 

end 

end 

else 

if  (symbol_type  -  integer_symbol_type)  then 
begin 

operand2  token? 

child_expression  last_expression(expression_level] ; 

if  not  evaluate  then  last_expression[expression_level]  last_expression(expression_level] *.left; 

create_index_terra; 

operand. id  operandl; 

operand. id_type  integer_syrabol_type; 

operand. index  blanket o ken; 

operand. of fset  0; 

insert_sibling_expression (operand, null_operator) ; 
token  operand2; 

symbol_type  integer_syrnbol_type; 
if  operatorl  -  plus_token  then 

expression_operator [expression_level]  addition 
else 

expression_operator [expression_level]  :■  subtraction; 
compound_arithmetic_expression; 

delete_expression(last_expression(expression_level] ) ; 

if  evaluate  then 

begin 

traverse_expres3ion_tree; 

end 

else 

begin 

last_expression [expression_level]  :«  child_expression; 
end; 
end 


else 
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begin 

vrite__error  (*  integer  type  expected  \ token); 

end; 
end 
else 

if  token  -  elose_square_bracket  then 
begin 

if  evaluate  then 

last_expressiontexpression_levelJ*. index  operandl 
else 

last_expression(expression_level] A. left*. index  :•  operandl; 

end 

else 

if  token  -  raultiply_token  then 
begin 

child_expression  s-  last_expression[expression_level] ; 

if  not  evaluate  then  last_expression[expression_level]  last__expression(expression_levelJ  *.left; 

create_index_term; 

operand. id  operandl; 

operand . id_type  integer_syrabol_type; 

operand. index  blank^token; 

operand. off set  0; 

insert_sibling_expression (operand, null_operator) ; 
expression_operator (expression_level]  multiplication; 
fetch_token; 

compound^ar ithmet ic_expr e s s ion ; 

delete_expression(last_expressiontexpression_level] ) ; 

if  evaluate  then 

begin 

traverse_expression_tree; 

end 

else 

begin 

last_expressiontexpression_level]  child_expression; 
end; 
end; 

end;  {  of  index_integer  ) 

Procedure  index_expression (evaluate: boolean) ; 
label  1; 

var  operandl, operand2, operator 1 :  token_type; 
operandl_value  j  longint; 
child__expression  s  expre3sion_pointer; 
operand2_symbol_type  :  longint; 
begin 
1  : 

constant_as3ignment_type  :«  integer_constant_symbol_type; 
find_symbol (token, symbol_type, symbol_value, found) ; 
if  symbol_type  -  integer_symbol_type  then 
begin 


index_integer (evaluate) ; 
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end 

else 

if  symbol_type  -  integer_constant_symbol_type  then 
begin 

index_constant_terra (evaluate) ; 

if  token  <>  close_square_bracket  then 

begin 

if  token  -  plus_token  then  fetch_token; 
goto  1  {  start  ); 
end; 
end 
else 

if  token  -  plus_ token  then 
begin 

fetch_token; 
goto  1  (  start  ); 
end 
else 

if  token  -  minus_token  then 
begin 

fetch_token; 

find_syrabol  (token,  symbol_type,  symbol_value,  found)  ; 
if  symbol_type  -  integer_constant_syrabol_type  then 
begin 

integer_constant_value  -integer_constant_value; 
index_constant_terni  (evaluate) ; 
if  token  <>  close^square^bracket  then 
begin 

if  token  -  plus_token  then  fetch_token; 
goto  1;  {  start  ) 
end; 
end 
else 

if  symbol_type  -  integer_symbol_type  then 
begin 

operandl  token; 

child_expression  last_expression(expression_level] ; 

if  not  evaluate  then  last_expression [expression_level]  last_expression[expression_level] * .left; 

create_expre3sion (new_expression) ; 

last_expr  ess  ion  [  expression_J.evel  ]*.  down  new_expression; 

new_expression* .up  s  —  last_expression [expression_level] ; 
last_expres3ion[expression_level]  new_expression; 
assign_percent_variable (token)  ; 

last_expression[expression_level] * . id  token; 
last_expressionfexpression__level]  *.  operator  unary_index; 
create_expression(new_expression) ; 

last_expression(expression_level] * . down  new_expression; 
new  expression* .up  last_expression (expression^level] ; 
last_expression[expression_level]  :  —  new_expression; 
str_integer (0, token) ; 
operand. id  token; 
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operand. id_type  integer_symbol_type; 
operand . index  blanket oken; 

operand. of fast  0; 

insert_sibling__expression  (operand,  null_operator ) ; 
express ion_operator [express ion_level]  subtraction; 

token  operandl; 
corapound_arithmetic_expressioh; 

delete_expression(last_expression(expression_level] ) ; 

if  evaluate  then 

begin 

traverse_expression_tree; 

end 

else 

begin 

la3t_expression[expression_level]  :«  child_expression; 
end; 
end; 
end 
else 

if  token  ■*  open_parenthesis  then 
begin 

child_expression  last_expression(expression_levell ; 

if  not  evaluate  then  last_expression{expression_level]  last_expression(expression— level] * .left; 

create_expression (new_expression) ; 

last_expression [expression_levelJ * . down  s-  new_expression; 
nevjexpression*  .up  last_expression(expression_levell ; 

last_expression[expression_level]  new_expression; 

assign__percent_variable  (token)  ; 
last_expression[expression_level] ".id  :•  token; 
last_expressionfexpression_level] " .operator  unary_index; 
create_expression (new_expression) ; 

last_expression[expression_level] " .down  new_expression; 
new_expression" .up  la3t_expre3sionfexpre3sion_levell; 

last_expression[expression_level]  new_expression; 

expression_operator [expression_level]  null_operator; 
token  openjparenthesia ; 
corapound_arithntetic_expression; 

delete_expression(last_expre3sion[expres3ion_level) ) ; 

if  evaluate  then 

begin 

traverse_expression_tree; 

end 

else 

begin 

last_expre3sion[expression_levelJ  child_expression; 
end; 
end 
else 
begin 

write_error( ’integer  expression  expected  ', token); 


end; 
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constant^ ssignraent_type  real_constant_syinbol_type; 

end;  (  of  index_expression  } 

Procedure  Boolean_expression; 
var  terap_token:token_type; 
b_op  :  longint; 
head_operand  :  operand_type; 
begin 

if  (token  -  true_token)  or  (token  -  false_token)  then 
begin 

if  write  iookahead_buffer [1] .id  <>  blank_token  then  generate_Nop; 

if  token  -  true_token  then 

begin 

(  branch_lookahead_buffer [0]  nojoranch; 

first  expression (expression_level] '".address (1]  :■  program_counter-2; 
first_expresaion(expression_level] *. address (2}  7fffH;  } 

end 
else 
begin 

branchy lookahead_buffer [0]  unconditional; 

first  expression (expression^ level] *. address (1]  :•  -program_counter+2; 
first_expression[expression__levell '".address (2]  7fffH; 

microcode__address  prograra_counter; 
output_raicrocode_field; 

program^counter  *"  prograra_counter  +  1; 
end; 

fetch_token; 

end 

else 

begin 

terap_token  token; 
percent_variable_counter  0; 
reset_temp_variable_address  ; 
assign_temp_variable (token) ; 
head_operand. id  token; 

head_gperand . id_type  boolean_symbol_type; 

head_operand . index  blank_token; 

head_operand. offset  0; 
reset_last_expression (head_operand) ; 
cr e  ate_expr e  s  sion (new_expression) ? 

last_expression(expression_level) A .down  :«  new_expression; 
new_expres3ion'* .up  : ■  last__expression [expression_level]  ; 
last_expression[expression_level]  new— expression; 

token  terap_token; 
corapound_a  r  i  thine  t  i  c_expr  e  s  s  i  on ; 

delete_expression(last_expression(expression_levell ) ; 
traverse_expression_tree; 
end; 

end;  (  of  boolean_expression  ) 

Procedure  arithmetic_term; 
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var  child_expression  :  expression_pointer; 

operand  :  operand_type; 
begin 

assign_percent_variable (token) ; 

child_expresaion  1 a st_expression [express ion_level] ; 

operand. id  :«•  token; 

operand.id_type  s-  syrobol_type; 

operand . index  blank_token; 

operand. off set  0; 

insert_child_expression( operand, expression_operator [expression_level] ) ; 

expression_operator [expression_level]  null__operator; 

fetch_token; 

compound__arithmetic_expression; 
verify^token (token, close_parenthesis) ; 
delete^expression (last_expression [expression_level] ) ; 
last_expression[expression_level]  child_expressionA .right; 
end;  {  of  arithmetic_terra  ) 

Procedure  standard_function_call (var  fx  :  operand_type) ; 
var  terap_constant_assignraent_type  :  longint; 
function_token  :  token_type; 
x  j  operand^type; 
begin 

tejnp_constant_a»signrcent_type  constant_assignment_type; 

function_token  token; 

fetch_token; 

verify_token (token, open_paren thesis ) ; 
fetch_pararaeter (x) ; 

verify_token (token, close_parenthe3ia) ; 
assign_parareeter (fx,real_syrobol_type) ; 
if  (function_token-trunc_token)  then 
begin 

function_trunc ( fx, x) ; 
end 
else 

if  (function_token-round_token)  then 
begin 

function_round ( fx, x) ; 
end 
else 

if  (function_token  -  exp__token)  then 
begin 

function_exp(fx,x) ; 
end 
else 

if  (function_token  -  ln_token)  then 
begin 

function_ln (fx, x) ; 
end 
else 

if  (function_token  -  sqrt_token)  then 
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begin 

funct ion_sqrt  (fx,x) ; 
end 
else 

if  <function_token  -  sin_to)cen)  then 
begin 

function_sin  ( fx,  x) ; 
end 
else 

if  ( funct ion_token  -  cos_token)  then 
begin 

function_cos <  fx,  x) ; 
end 
else 

if  ( fynct ion_token  -  tan_token)  then 
begin 

funct ion_tan  ( fx,  x) ; 
end 
else 

if  ( function_token  -  asin^token)  then 
begin 

function_asin  { fx,  x) ; 
end 
else 

if  { f unction_token  -  acos_token)  then 
begin 

function^acos (fx, x) ; 
end 
else 

if  ( funct ion_token  -  atan_token)  then 
begin 

funct ion_atan  <  fx, x) ; 
end 
else 
begin 

write_error ( * unsupported  function  ' , funct ion^to ken) ; 

end; 

const ant_assignment_type  : -  terap_constant_assignment_type; 
end;  {  standard_function_call  ) 

Procedure  unary__arithmetic_expression; 
var  child_expression  :  expression_pointer; 

operand  :  operand_type; 
begin 

child_expression  nil; 
if  (token-minus_token)  then 
begin 

if  expression_operator [expression_level]  -  subtraction  then 
expression^ operator [expression^level]  addition 


else 

begin 
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child_expression  last_expression{expression_level] ; 

assign _percent_variable {token) ; 

operand. id  token; 

operand.id_type  symbol_type; 

operand. index  blank_token; 

operand. off set  0; 

insert_child_expression (operand, expre3sion_operator [expression_level] ) ; 
expression_operator [expression_level]  unary^minus; 

end; 
end 
else 

if  (token-plus_token)  then 
begin 

{do  nothing) 
end 
else 

if  (token-not_token)  then 
begin 

child_expression  last_expression[expression_level]; 

as sign_percent_variable (token) ; 

operand. id  token; 

operand . id_type  syrabol_type; 

operand. index  blank_token; 

operand. offset  0; 

insert^child^expression (operand, express ion_operator [expression_level] ) ; 
expression_operator [expression_level]  unary_not; 
end; 

fetch_token; 

siraple_arithraetic_expression; 
if  child_expression  <>  nil  then 
begin 

delete_expression (last_expression (expression_level) ) ; 
last_expression(expre39ion_level]  child^expression'* .  right; 
end; 

end;  {  of  unary  arithmetic  operator  ) 

Procedure  arithmetic__constant; 
var  operand  :  operand_type ; 
begin 

find_syrabol (token, symbol_type, symbol_value, found) ; 
if  ( (3yrabol_type  -  integer_constant_symbol_type)  or 
<3ymbol_type  -  real_constant_3ymbol_type) )  and 
(not  found)  then 
begin 

symbol_type  real_con3tant_3ymbol_type; 

val_real (token, real_constant_value, i) ; 
str_real (real_constant_value, token) ; 
end; 

operand. id  token; 
operand. id_type  syrabol_type ; 
operand. index  blank_token; 
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operand. offset  0; 

insert  sibling_expression (operand, expression_operator [expression_level] ) ; 

expression_operator Iexpression_level]  null_operator; 

find_symbol (token, syrebol_type, symbol_value, found) ; 

if  not  found  then 

begin 

insert_symbol (token, syrabol_type, syrabol_value) ; 
declare_constant (symbol_value,  syrabol_type, token) ; 
end; 

end;  {  of  arithmetic_constant  ) 

Procedure  simple__arithmetic_expression; 

var  fx,x, operand, index_operand  :  operand_type; 

begin 

find_symbol  (token,  synbol_type,  syrabol_value,  found) ; 
if  ( (symbol_type  -  integer_constant_syrabol_type)  or 
(symbol_type  -  real_constant_symbolj:ype) )  and 
(not  found)  then 
begin 

insert_symbol (token, symbol_type, syrabol_value) ; 
declare_constant (symbol_value, symbol_type, token) ; 
end; 

if  expression_operator [expression_level]  ■  division  then 

begin 

fetch_operand (x) ; 

assignjaarameter  (fx, real_symbol_type) ; 
generate__reciprocal  (fx,x)  i 

expression_operator [expression_level]  multiplication; 
insert^ sibling_expression ( fx, expression_operator ( expression_level) )  ; 
express ion_operator (expression_level]  :•  null_operator; 
end 
else 

if  token  -  open_parenthesis  then 
arithmetic_terra 
else 

if  (symbol_type  -  standard_function_syrabol_type)  then 
begin 

standard_function_call  (operand) ; 

insert_sibling_expression (operand, expression_operator £expres3ion_level] ) ; 
expression_operator (expression_level)  null__operator; 

end 
else 

if  (symbol_type  -  function_symbol_type)  then 
begin 

function_call  (operand) ; 

insert  sibling_expression (operand, expression_operator [expression_level] ) ; 
expression__operator  [expression_level]  null_operator; 

end 
else 

ir  (symbol_type  -  real_symbol_type)  or 
(symbol_type  -  integer_symbol_type)  or 
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( syrcbol_type  -  boolean_symbol_type)  or 
(symbol_type  -  boolean_con3tant_symbol_type)  then 
begin 

operand. id  token; 
operand . id_type  »ymbol_type; 

operand . index  blank_token; 
operand. offset  0; 

insert_sibling_expression(operand,  expression_operator [expression_level] ) ; 
expression_operator  [expression__level]  null_operator; 
end 
else 

if  (symbol_type  -  real_constant_symbol_type)  or 
(aymbol_type  -  integer^ constant_symbol_type)  then 
arithraetic_constant 
else 

if  (symbol_type  -  real__array_syrobol_type)  then 
begin 

symbol_type  :«  real_symbol_type; 

operand. id  token; 

operand .  id_type  symbol__type; 

fetch_token; 

verify_token (token. open_square_bracket ) ; 
fetch— index (index^oper and) ; 
operand . index  index_operand. id; 
operand. off set  index__operand.offset; 

verify_token (token, close_square_bracket) ; 

insert_sibling_expression (operand, expression_operator [expression_level] ) ; 
end 
else 

if  (symbol_type  «  integer_array_syinbol_type)  then 
begin 

syrabol_type  integer_symbol_type ; 

operand. id  token; 

operand . id__type  symbol_type ; 

fetch_token; 

verify_token (token, open_aquare_bracket) ; 
fetch__index  (index_operand) ; 
operand . index  index_operand.id; 
operand. off set  index_operand. offset; 

verify_token (token, close_square_bracket) ; 

insert_sibling_expression (operand, expression_operator [expression_level] ) ; 
end 
else 

if  (symbol_type  -  boolean_array_symbol_type)  then 
begin 

symbol_type  :  -  boolean_symbol_type; 

operand. id  token; 

operand . id_type  :«•  3ymbol_type; 

fetch__token; 

verify_token (token, open_square_bracket) ; 
fetch_index(index_operand) ; 
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operand. index  index^operand.id; 
operand. offset  :•»  index_operand.offset; 
verify_token (token, close_square_bracket) ; 

insert_sibling_expression (operand, expression_operator {expression_level] ) 
end 
else 
begin 

write_error { *  invalid  id  ' *  token) ; 

end; 

end;  {  of  simple  arithmetic  expression  ) 

Procedure  arithmetic_expression; 
begin 

if  (token  -  rainus_token)  or  (token  -  plus_token)  or 
(token  -  not_token)  then 
unary_arithraetic_expression 
else 

simple_arithraetic_expression; 
end;  (of  arithmetic_expression) 

Procedure  compound_arithraetic_expression; 
begin 

arithraetic_expression; 
fetch— token; 

if  (token-plus_token)  then 
begin 

expression_operator [expression_level]  :•  addition; 
fetch_token; 

compound_arithraetic_expres  sion ; 
end 
else 

if  (token-rainus_token)  then 
begin 

expres3ion_operator [expression_level]  :»  subtraction; 
fetch_token; 

compound_arithmet ic_expr ession ; 
end 
else 

if  (token-multiply_token)  then 
begin 

express ion_operator[ express ion_level]  multiplication; 

fetch_token; 

corapound_a  r i t hmet ic_expression; 
end 
else 

if  (token-divide_token)  then 
begin 

expression_operator (expression_level)  division; 

fetch_token; 

compound_arithmetic_expression; 


end 
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else 

If  (token-greater_than_token)  then 
begin 

expression_operator texpression_level]  greater_than; 
fetch_token; 

corapound_arithraetic_expression; 

end 

else 

if  (token-greater_than_or_equal_token)  then 
begin 

expression_operator [expression_level]  :»  great er_than_or__equal; 
fetch_token; 

corapound_arithmetic_expression; 

end 

else 

if  (token-less_than_token)  then 
begin 

expression_operator texpression__level]  less^than; 

fetch_token: 

compound_arithmetic_expression; 

end 

else 

if  (token-less__than_or_equal_token)  then 
begin 

expression_operator texpression_level]  less_than_or_equal; 

fetch_token; 

corcpound_arithmetic_expression; 

end 

else 

if  (token-equal_token)  then 
begin 

expression_operator[expression_level]  equal; 

fetch_token; 

compound_ar ithmetic^expr e  s  s ion ; 
end 
else 

if  (token-not_equal_token)  then 
begin 

expression_operator [expression_level]  not_equal; 

fetch_token; 

compound_arithmetic_expre3sion; 

end 

else 

if  (token«and__token)  then 
begin 

expression_operator [expres3ion_level]  and_operation; 

fetch_token; 

compound_a r i thme t i c_e xpr e s 3 i on ; 
end 
else 

if  (token-  or_token)  then 


Digital  Emulation  Technology  Laboratory  Final  Report 


53 


begin 

expression_operator l expression  Jlevel]  or_operation; 

fetch_token; 

compound_arithraetic_expression; 

end; 

end;  {  of  compound  arithmetic  expression  ) 

Procedure  index_assignraent_statement; 

var  head_ operand, index_operand  :  operand_type; 

begin 

{  writeln<  out  file,  * ; - expression  ' , expression_number, ' - *);  } 

clear_temp_index ; 

r e s e t_t emp_va r i a ble_a d dr e s s ; 

expres»ion_number  s-  expres»ion_number  +  1; 

percent_variable_counter  0; 

head_oper and . id  s-  token; 

head_oper and . id_ type  : -  syrabol_type ; 

fetch_token; 

verify_token (token, open_square_bracket) ; 
fetch_index(index_operand) ; 
head_oper and. index  index_operand.id; 

head_oper and. offset  index_operand.offset; 
reset_last_expression (head_operand) ; 

expression_operator [expression_levelJ  null_operator; 

last_expression(expression_level]  first_expression[expression_level] ; 

verify_token (token, closejsquare_bracket) ; 
create_expression (new_expression) ; 

last_expressiontexpression_level] A.down  new_expression; 

nev_expression*.up  last_expression[expression_level] ; 

last_expression[expression_level]  new_expression; 

fetch_token; 

verify_token (token, colon) ; 
fetch_token; 

verify__token  (token,  equal_token) ; 
fetch_token; 

corapound_arithraetic_expression; 

delete_expression(last_expression[expression_levelj ) ; 
traver se_expression_tree ; 
end;  (  of  index_assignment_statement  ) 

Procedure  general_expression(head_operand  :  operand_type) ; 
begin 

{  vriteln(outfile, * ; -  expression  ’ , expression_number, ’  - *);  1 

expression_number  s-  expression_number  +1; 
percent_variable_counter  0; 
reset_last_expression(head_6perand) ; 
create_expression (new^expression) ; 

last_expression  [expresslon_JLevel  J  A  .  down  ;*  new_expression; 
new_expression<' .up  last_expressiontexpression_level] ; 
last_expression [expression_level]  new_expression; 


fetch  token; 
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corapound_arithraetic_expression; 

delete_expression{last_expression[expression_level] ) ; 
transforra_expression_tree; 
end;  {  of  general^expression  } 

Procedure  assignment_3tatement; 
var  head__operand  :  operand_type; 
begin 

{  writeln(outfile, ’ ; -  expression  *,expression_number, '  - ');  > 

expression_number  expressionjnuraber  +  1; 
clear_temp_index; 
percent_variable_counter  s-  0; 
head_operand . id  :«  token; 
head_operand.id_type  syrabol^type; 
head_operand .  index  blank_token; 

head_operand.offset  0; 
reset_last_expression{head_operand) ; 
create_expression (new_expression) ; 

last_expression{expression_level} A.down  new_expression; 
new^expression* .up  last_expressionIexpression_level] ; 
last_expression{expression_level]  new_expression; 
fetch_token; 

verify_token (token, colon) ; 
fetch_token; 

verify_token (token, equal^token) ; 
fetch_token; 

reset_terap_variable_address; 
corapound_a rit hmet ic_expres s i on ; 

delete_expression (last_expression [expression_level] ) ; 
t raver se_expression_tree; 
end;  {  of  assignraent_statement  ) 

Procedure  procedure_call; 

var  procedure_address  ;  longint; 

reference_actual_parameter  :  array (0. .raax_reference_parameter]  of  operand_type; 
reference_forraal_pararaeter  :  array [0. .max_reference_parameter]  of  operand_type; 
i  :  longint; 

no_reference_parameter  :  longint;  {  use  to  keep  track  of  the  number  of  call  by  value  parameters  } 
actual_parameter, forraal_pararaeter :  operand_type; 
begin 

for  i  ;•  0  to  max_index_register  do  index_register [i]  blank_token; 

reset__temp_variable_address; 

no_reference_parameter  0; 

current_parameter  procedure_link* .parameter_link; 

procedure_address  procedure_link~ .value; 

if  current^parameter  <>  nil  then 
begin 

fetch_token; 

verify_token (token, open_parenthesis) ; 
while  current_parameter  <>  nil  do 
begin 
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fetchjpararoeter  (actual_pararaeter)  ; 
syrabol_type  actual_j3arameter .id_type; 

find_symbol  (aetual_parameter .id,  syrabol_type,  symbol_value,  found) ; 
expression_number  :•»  expression__number+l; 
slmpl i f y_type (symbol_type) ; 

if  symbol  type  <>  current_parameterA .id_type  then 

vrite_error ( ' Type  mismatch  :  *  * actual_parameter . id) ; 

str  integer (current_parameter~. address, forma l_parameter .id) ; 
terap_token  blank_token; 
temp__token  [  1  ]  ;•  '**; 

concat  (terap__token,  f ormal_parameter .  id)  ; 
formal_parameter.id  :■  terap_token; 

formal ^parameter . id_type  : -  current _pararaeter~ . id_type ; 

formal_pararaeter .offset  0; 

forma l_parame ter  .index  blank_token; 

generate_ALU_operation(formal__pararaeter,  actual_parameter,  zero__operand,  addition) ; 

if  current_pararaeter''  .parameter_type  -  call_by_reference  then 

begin 

no_reference^parameter  s—  no_reference _parameter+l; 
if  actual_j>arameter.id(ll  -  *#'  then 

write_error ( ' call  by  reference  parameter  is  expected  ’ ,blank_token) ? 

reference_actual_parameter [no_reference ^parameter]  actual_parameter; 

reference_formal_pararaeter Eno_reference_parameter]  forma l_parameter; 

end; 

current_parameter  s-  current^pararaeter^.next; 
if  current_parameter  <>  nil  then  verify_token (token, comma) ; 
end; 

verify_token (token, close_parenthesis) ; 
end; 

if  (vrite_lookahead_buffer [1] .id  <>  blank_token)  then  generate_Nop; 
if  (branch_lookahead_buf fer [0]  <>  no_branch)  then  generate_Nop; 
writeln (outf ile, ' ; • , program_counter , f :  gosub  * , procedure_address) ? 
microcode_address  :  —  pr ogram_counter ; 
branch_address  proeedure_address; 

AM2910_opcode  CJS; 

branch_opcode  unconditional; 

output_microcode_field: 
prograra__counter  s-  program_counter  +  1; 
for  i  ;■  1  to  no_reference_parameter  do 
begin 

generate_ALU_operation  (reference_actual_pararaeter  [ i ]  ,  reference_formaljparameter  [ij ,  zero_operand,  addition) ; 
end; 

for  i  0  to  max_index_register  do  index_register {il  blank_token; 
fetch_token; 

end;  {  of  procedure_call  ) 

Procedure  function_call (var  fx  :  operand_type) ? 
var  procedure_address  :  longint; 

reference  actual  parameter  ;  array [0 . .max_reference_parameter]  of  operand_type; 
reference_formal_parameter  ;  array [0 . .max_reference_parameter]  of  operand_type; 
i  :  longint; 
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no_reference_parameter  :  longint;  {  use  to  keep  track  of  the  number  of  call  by  value  parameters  } 
actual_parameter, forma ljpararaeter:  operand_type; 
function__operator  :  longint; 
x  :  operand_type ; 

current_pararaeter  :  pararaeter_pointer; 
begin 

for  i  :■  0  to  max_index_register  do  index_register[i]  blank_token; 
function_operator  expression_operator [expression_level] ; 
no_reference_parameter  0; 

current_parameter  :•  procedure_link* .parameter_link; 
str_integer  (current^pararaeter'*. address,  fx.id)  ; 
temp__token  blank_token; 
temp_token(ll 

concat  {temp_token,  fx.id); 
fx.id  terap_token; 

fx.id_type  current ^parameter*. id_type; 
fx. index  s-  blank_token; 
fx. offset  0; 

current^ parameter  current_pararaeterA.next; 

procedure^address  procedure_linkA .value; 

if  current_pararaeter  <>  nil  then 
begin 

fetch_token; 

verify^token (token, open_parenthesis) ; 
while  currentjpararaeter  <>  nil  do 
begin 

fetch_parameter  (actual_parameter) ; 
syrabol_type  s-  actual_pararaeter.id_type; 

find_syrabol(actual_parameter.id, symbol_type, symbol_value, found) ; 
expression_number  expression_number+l; 
simplify_type (symbol_type) ; 

if  syrabol_type  <>  current  jparameter* . id_type  then 

write_error ( ’Type  mismatch  :  actual jparameter. id) ; 

str_integer (current_parameter* .address, formal_parameter .id) ; 
temp_token  blank_token; 
temp_t oken ( 1  ]  : -  ’  # * ; 

concat (temp ^token,  formal  jparameter .id) ; 
formal__parameter.id  temp_token; 

formal  jparameter . id_type  current  jjarameter* .id_type; 

formal jparameter. off set  0; 

forma l_parameter .index  blank_token; 

generate_ALU_operation ( formal ^parameter, actual_parameter, zerojaperand, addition) ; 

if  current_parameter*.parameter_type  -  call _by_reference  then 

begin 

no_reference_parameter  no_reference__parameter+X; 

if  actual  jaarameter. id [1]  -  then 

write_error ( ’call  by  reference  parameter  is  expected  ’ , blank_token) ; 

reference_actual_parameter [no_reference_parameter]  :«  actual_parameter; 
reference_formal_parameter [no  jreferencejparameter]  forma  ^parameter; 

end; 

current_parameter  current  jaarameter* . next; 
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if  current_parameter  <>  nil  then  verify__token  (token,  comma) ; 
end; 

verify_token (token, close_parenthesis) ; 
end; 

if  (vrite_lookahead_buf fer [1] . id  <>  blank_token)  then  generate_Nop; 
if  (branch_lookahead_buffer(01  <>  no_branch)  then  generate_Nop; 
vriteln (out file, * ,prograra_counter, * s  gosub  • ,procedure_addres3) ; 
microcode  address  : ■  program_counter; 
branch_address  procedure_address; 

AM2910_opcode  CJS; 
branch_opcode  ;■»  unconditional; 
output  jnicrocode_f  ield ; 
program_counter  program_counter  +  1; 

for  i  1  to  no_reference_pararaeter  do 
begin 

generate  ALU__operation  (reference_actual_jiarameter  ti]  #  reference_forraal_parameter  [i] ,  zero_operand,  addition)  ; 
end; 

x  i-  fx; 

assign_parameter (fx, fx.id_type) ; 

generate_ALU_operation (fx, x,  zero_operand,  addition)  ; 

for  i  !•  0  to  max_index_register  do  indexer egis ter (i]  s-  blank_token; 
expression_operator [expression_level]  : “  function_operator ; 
for  i  s-  0  to  max_index_register  do  index_register [i]  blank_token; 

end;  (  of  function_call  ) 

Procedure  fetch_parameter (var  parameter  :  operand_type) ; 

var  found  :  boolean; 

begin 

expression_level  ;«■  expression_level+l; 
crea t e_expr es  sion (new^expr e  s  sion ) ; 

first_expression[expression__levelI  new_expression; 

{  assign_stack_operand (parameter, general_symbol_type) ;  } 
assign_dummy_parameter (parameter) ; 
constant_assignraent_type  real_symbol_type; 
reset_temp_variable_address; 
general__expression  (parameter) ; 

current_expression  first_expre3sionlexpression_levell ; 

(  node_display (current_expre3sion) ; 

node_display  < cur rent__expres sion'' . down) ;  ) 

if  assignment_nece3sary (current_expression)  then 

begin 

assign^ parameter (parameter, parameter . id_type) ; 
current^expression^.id  :»  parameter. id; 
current_expre3sion/' .  id_type  ; -  parameter .  idjrype; 
evaluate_expression_tree; 

fetch_expres3ion_operand (current_expres sion, parameter) ; 
end 
else 
begin 

fetch_expression_operand  (current_expre3sion'' .  down,  parameter) ; 
dispose  (current_expre3sion'' . down1* .  right) ; 
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dispose  (current^expression'*. down) ; 

{  free_stack__operand;  ) 
end; 

dispose (first_expression[expres3ion_level] ) ; 
expression_level  expression_level-l; 

end;  {  of  fetchjparameter  } 

Procedure  fetch_assigned_parameter (parameter  :  operand_type) ; 

(  to  fetch  a  parameter  that  has  been  allocated  a  location  in  the 
data  memory  } 
var  found  ;  boolean; 
begin 

expression_level  expression_level+l; 

create_expression (nev_expression) ; 

first_expression[expression_level]  nev_expression: 
Constantsa ssignment_type  real_symbol_type; 
reset_temp__variablesaddress; 
general_expression (parameter) ; 

currentsexpression  first_expres3ion(expression_levell ; 

(  node^display (currentsexpression) ; 

node^di splay (current_expressionA . down) ;  )  - 

evaluat  e__expr  es  sion_t  r  ee ; 

fetch_expression_operand(current_expression,pararaeter) . 

dispose (first_expression[expression_level] ) ; 
expression_level  expression_level  -1; 

end;  {  of  fetch__assignedsPararaeter  } 

Procedure  fetch_index(var  index  :  operand_type) ; 
var  found  :  boolean; 
i  :  longint; 

constantsOffset  :  longint; 

begin 

express ion_level  expression_level+l; 

create_expre33ion ( new_expr e  s  s ion ) ; 

firstsexpression(expression_level]  ;«  new^expression; 
assign_dumrayjparameter (index) ; 
index. id^type  integer_symbol_type ; 

eonstant_assignment_type  integer_syrabol_type; 

general_expression (index) ; 

current_expression  first__expression(expression_level] ; 

(  node_display (current_expression) ; 
node_display (current_expressionA .down) ; 
node_display (current_expressionA .downA .right) ;  ) 
if  index_assignment_nece3sary(current_expression)  then 
begin 

assign_parameter (index, index. id_type) ; 
current_expressionA.id  index. id; 

current_expressionA.id_type  index. id^type; 
evaluate_expression_tree; 

fetchsexpression_operand(current_expression, index) ; 


end 
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else 

begin 

val_integer  (current_expressionA  .down-*  .right*  .id,  const ant_off set,  i) 

fetch_expression_operand(current_expression*.downr index) ; 

if  current^ expression'” .  down* .  right'* .  operator  -  subtraction  then 
index. offset  index. offset  -  constant_offset 

else 

index. off set  index. offset  +  constant_offset; 

dispose {current_expression* . down"” .  right) ; 
di spose( cur rent_expr ess ion* .down) ; 

(  free_stack__operand;  ) 
end; 

dispose (first_expression [expression_level] ) ; 
expression^level  expression_level  -1; 

end;  {  of  fetch_index  } 

procedure  fetch_operand(var  operand  s  operand_type) ; 

var  index_operand  :  operand_type; 

begin 

reset_operand (operand) ; 

if  token  -  open_jiarenthesis  then 

begin 

fetchjoarameter (operand) ; 
symbol_type  operand . id_type ; 

end 
else 

if  (symbol_type  -  standard_function_3ymbol_type)  then 
begin 

standard_function_call (operand) ; 
symbol_type  operand. id_type; 

end 
else 

if  (symbol_type  -  function_symbol_type)  then 
begin 

function__eall  (operand) : 
syrabol_type  operand. id_type; 
end 
else 

if  ( syrabol_type  -  real_symbol_type)  or 
(syrabol_type  -  integer_symfaol_type)  or 
(symbol_type  —  real_eonstant_synibol_type)  or 
(s%%(  PrinterErryttalJsype  -  integer jxnstantj^  )  then 

begin 

operand. id  token; 
operand. id_ type  symbol_type; 

operand . index  blank_token; 
operand. offset  0; 
end 
else 

if  ( symbol_type  -  real_array_syrnbol_type)  then 
begin 
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symbol_type  rea l_symbol_type ; 

operand. id  token; 

operand .  id__type  symbol^ type; 

fetch_token; 

verify_token (token, open_square_bracket) ; 
fetch_index(index__operand> ; 
operand . index  index_operand.id; 
operand. off set  index_operand.offset; 

verify__token  (token,  close_square_bracket)  ,* 
end 
else 

if  (symbol_type  -  integer_array_symbol_type)  then 
begin 

symbol_type  integer_symbol_type; 

operand. id  token; 

operand . id_type  symbol_type; 

fetch_token; 

verify_token (token, open_square_bracket) ; 
fetch_index (index_operand) ; 
operand . index  index_operand. id; 
operand. offset  index_operand.offset; 
verify_token (token, close_square_bracket) ; 
end 
else 

if  ( syrebol_type  -  boolean__array_symbol_type  >  then 
begin 

symbol^ type  boolean_symbol_type; 
operand. id  token; 

operand. id_type  symbol_type ; 
fetch_token; 

verify_token (token, open_square_bracket) ; 
fetch_index (index_operand) ; 
operand. index  index_operand. id; 
operand. offset  index_operand . offset; 

verify_token (token, close_square_bracket) ; 
end 
else 
begin 

write_error ( ' invalid  id 
end; 


’ ,  token) ; 


end;  . 
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File:  BIT_FUNC.DEF 
public  bit_ func; 

function  word_shr (value ,num: word) :word; 
function  word_shl (value, nura: word) :word; 
function  word_and (value, nura: word) :word; 
function  word_or (value, nura: word) :word; 
function  word_xor (value, nura: word) :word; 
function  dword_shr (value, nura: word) :longint; 
function  dword_shl( value, nura: word) slongint; 
function  dword__and  (value,  nura:  word)  :longint; 
function  dword_or (value, nura: word) :longint; 
function  dword_xor (value, nura: word) :longint; 
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File:  BIT_FUNC.PLM 
bit_funcs:  do; 

word_or  :  procedure  (  valuel,  value2  ) 

declare  (  valuel,  value2  )  word; 

return  (valuel  or  value2); 

end  word_or; 

word_and  :  procedure  (  valuel,  value2 

declare  (  valuel,  value2  )  word; 

return  (valuel  and  value2) ; 

end  word_and; 

word_shl  :  procedure  (  valuel,  count  ) 

declare  (  valuel,  count  )  word; 

return  (  shl (valuel, count)  ); 

end  word^shl; 

word_shr  :  procedure  (  valuel,  count  ) 

declare  (  valuel,  count  )  word; 

return  (  shr (valuel, count)  ); 

end  word_shr; 

word_xor  :  procedure  (  valuel,  value2 

declare  (  valuel,  value2  )  word; 

return  (  valuel  xor  value2  ) ; 

end  word_xor; 

dword_or  :  procedure  (  valuel,  value2 

declare  (  valuel,  value2  )  word; 

return  (valuel  or  value2); 


word  public; 


)  word  public; 


word  public; 


word  public; 


)  word  public; 


)  dword  public; 
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end  dword_or; 

dword_and  :  procedure  (  valuel,  value2 
declare  (  valuel,  value2  )  word; 

return  (valuel  and  value2); 

end  dword_and; 

dword_shl  :  procedure  (  valuel,  count  ) 
declare  (  valuel,  count  )  word; 

return  (  ahl (valuel, count)  ); 

end  dword_shl; 

dword_shr  :  procedure  (  valuel,  count  ) 

declare  (  valuel,  count  )  word; 

return  (  shr (valuel, count)  ); 

end  dword^shr; 

dword_xor  :  procedure  (  valuel,  value2 
declare  (  valuel,  value2  )  word; 

return  (  valuel  xor  value2  ) ; 

end  dword_xor; 

end  bit  funcs; 


)  dword  public; 


dword  public; 


dword  public; 


)  dword  public; 


File:  CODE  GEN.DEF 


public  code_gen; 

procedure  swa proper and (var  R, S :operand_type) ; 

Procedure  reset_raicrocode_field; 

Procedure  display_branch_condition; 

Procedure  outputjnicrocode^field; 

Procedure  generate_Nop; 

Procedure  display_ALU_operation (F, R, S : operand^type; opcode : longint ) ; 

Procedure  Bind_ALU_opcode ( opcode  :  longint); 

Procedure  Bind_AF_AR_AS(F,R,S:operand_type) ; 
procedure  bind_AIF_AIR_AIS (F, R, S : operand_type) ; 

Procedure  generate_ALU_operation (F,  R,  S : operand_type ; opcode : longint ) ; 

Procedure  Clear_pipeline— stage; 

Procedure  check_F_bus (operand  :  oper and_type ) ; 

Procedure  load_index_register (index  ;  token_Type) ; 

Procedure  check_index_register (var  F,R,S  :  operand_type) ; 

Procedure  check_pipeline__stage (var  F,R,S:operand_type;var  opcode  :longint); 
Procedure  find_hranch_address (var  expression  :  expression_pointer; 

var  branch_state  :  longint) ; 
procedure  generate__boolean__assignment_microcode  (var 

expression  :  expression_pointer ; 
branch_true  :  boolean) ; 

Procedure  generate_branch_address (var  expression  :  expression_pointer) ; 
procedure  assign_temp_boolean_variable (var  F  :  operand_type) ; 
procedure  generate_greater__than(var  expression  :  expression_pointer) ; 
procedure  generate_less_than(var  expression  :  expression_pointer) ; 
procedure  generate_equal (var  expression  :  expression_pointer) ; 
procedure  generate_not_equal (var  expression  :  express ion_pointer) ; 
procedure  generate_greater_than_or_equal (var 

expression  :  expression_pointer) ; 

procedure  generate_less_than__or_equal (var  expression  :  expression_pointer ) ; 
Procedure  generate_unary_not (var  expression  :  expression_pointer) ; 
procedure  generate^ and (var  expression  :  expression_pointer) ; 
procedure  generate_or (var  expression  :  expression_pointer) ; 
function  assign_index (index  :  token_type) : longint; 

Procedure  generate_read_function (function_number  :  longint; fx,x  :  operand_type) ; 
Procedure  assign_R__bus  (operand ;operand__type)  ; 

Procedure  assign_S_bus (operand: operand_type) ; 

Procedure  assign__F__bU3  (operand :operand_type) ; 
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Pile:  CODE_GEN.PAS 
module  code_gen; 

$include (code_gen . def ) 

$ include (global . def) 

$ include (utility . def) 

$include ( symbol_t , def) 

^include (emu^lib . def) 

private  code_gen; 

Procedure  assign_R_bus (operand :operand_type) ; 
begin 

AR  operand.  id__address  +  operand. offset; 

if  (operand. index  <>  blank_token)  and  (operand. id (11  <>  '#*)  and 
(operand. index [1]  <>  *0’)  and  (operand. id [1}  <>  ’  S*)  then 
begin 

AIR [01  operand. index_addr ess; 

IA1  1; 
end; 

end;  (  of  assign_R_bus  ) 

Procedure  assign_S_bus (operand: ope rand_type) ; 
begin 

AS  operand. id_addr ess  +•  operand. off set; 

if  (operand. index  <>  blank_token)  and  (operand. id [1]  <>  **')  and 
( operand . index (11  <>  *0')  and  (operand. id(l]  <>  *«f)  then 
begin 

AIS [0]  operand. index_address; 

IA0  1; 

end; 

end;  (  of  assign_S_bus  } 

Procedure  assign_F_bus  (operand :operand__type)  ; 
begin 

AF [0]  operand. id_address  +  operand. off set; 

if  (operand. index  <>  blank_token)  and  (operand.iddl  <>  '#’)  and 
(operand. index (11  <>  *0*)  and  (operand. id [1 ]  <>  *  s')  then 
begin 

AIF [ 0 ]  operand. index_addre ss ; 

IA2[0]  1; 

end; 

end;  (  of  assign_F_bus  ) 

Procedure  reset_microcode_field; 

var  i  :  longint; 

begin 

am2910_opcode  :«  cont; 
branch_address  0; 
branch^opcode  nojoranch; 
for  i  1  to  2  do 
begin 

write  lookahead_buf fer (i-11  write_lookahead_buf fer fi] ; 
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AFfi-1]  :-AFr±l? 

branch_lookahead_buffer  [i-1]  :«■  branch_lookahead_buffer [i] ; 

AIF [i-1]  AIF [i] ; 

IA2[i-l]  IA2  [i]  ; 
end; 

AIRfO]  AIR(1J ; 

AIS[0]  AISC1] ; 

AIR  [11  7fffH; 

AIS(1]  7fffH; 

AIF [2]  7fffH; 

with  write_lookaheadjouf fer [2]  do 
begin 

id  blanks token; 

index  blank_token; 

offset  0; 

end; 

branch_lookahead_buffer [2]  7fffH; 

AF[2]  0; 

mc325_buffer[0]  mc325Jbuffer (1] ; 

mc325_buffertU  0; 

14  0; 

ENF_bar  0; 

Dsel  s-  0; 

13 [0]  13 [1] ; 

13  [1]  0; 

rasw  0; 

read_opcode  0; 

IA2I2]  0; 

IA1  0; 

IA0  0; 

AR  1; 

AS  1; 

write_opcode  0; 
end; 

Procedure  display_branch_condition; 
begin 

if  branch_opcode  -  0  then 

writeln<outfile, ' ; * ,raicrocode_address, * :  branch  if  Network  FIFO  has  no  data') 
else 

if  branch_opcode  -  1  then 

writelntoutfile, ' ; * ,raicrocode_address, * ;  branch  if  Network  FIFO  is  not  ready  for  input’) 
else 

if  branch_opcode  -  2  then 

writeln(outfile, ' ; * ,microcode_address, ' :  branch  if  Host  FIFO  has  no  data’) 
else 

if  branch_opcode  -  3  then 

writeln (outfile, ' ; * ,microcode_address, ' ;  branch  if  Host  FIFO  is  not  ready  for  input') 
else 

if  branch_opcode  -  4  then 

writeln (outfile, ' ; * , microcode_address, ' ;  branch  if  zero') 
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else 

if  braneh_opcode  *.  5  then 

writeln (outfile, * ; * ,microcode_addreas, * :  branch  if  not  zero') 
else 

if  branch_opcode  -  6  then 

writeln ( out file, * ; *  ,microcode_address, * :  branch  if  negatif ' ) 
else 

if  branch_opcode  -  7  then 
begin 

am2910_opcode  eont; 
writeln (outfile, ' ;  Nop'); 
end 
else 

if  braneh_opcode  -  9  then 

writeln (out file, ' ; * ,microcode_address, ' :  branch  if  not  negatif) 
else 

if  branch_opcode  -  OAH  then 

writeln (out file, ' ,microcode_address, • :  branch  if  error  ') 
else 

if  branch_opcode  -  OCH  then 

writeln (outfile, *; * ,microcode_addres3, ' :  unconditional  branch' ) 
else 
begin 

writeln  (errorfile); 

writeln  (errorfile,  'unknown  branch  opcode  :  ' ,branch_opcode) ; 
error_found 
end 
end; 


Procedure  output_microcode_field; 
begin 

if  AIF[0]  -  7fffH  then  AIF[0]  0; 

if  AIR [0 1  -  7fffH  then  AIR[0]  0; 

if  AIS[0)  -  7fffH  then  AIS[0]  0; 

if  write_opcode  -  0  then 

begin 

if  (write_lookahead_buffer  [0] .id  <>  blank_token)  then 
write_opcode  :■  1; 

end; 

if  branch_lookahead_buffer  [0)_  <>  7fffH  then 
begin 

am2910_opcode  CJP; 

branch_opcode  branch_lookahead_buffer (0] ; 

display_branch__condition; 
end; 

write (outfile, 'c  ' ,microcode_address : S) ; 

write (outfile, am29l0_opcode:3, branch_address : 5, branch_opcode: 3, write_opcode : 3) ; 
write (outfile. Dsel: 2, read_opcode:2,ENF_bar : 2, 14:2, 13(0) :2,MC325_buffer [0] :3) ; 
writeln  (outfile,  AF[0]  :  5,  AR:  5,  AS  :  5,nisw:  2,  IA2  [0]  :2,  IA1 :2,  IAO:2,AIFtO]  :3,AIR(0]  :3,AIS(0}  :3) 
reset  microcode  field; 
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if  microcode_address  >  prograra_counter_liniit  then 
begin 
writeln; 

writeln (errorfile, 'Microcode  address  exceeds  * , program_counter_lirait) ; 
writeln (error file, 'Try  to  partition  this  process  into  two  processes.  '); 
error_found; 
end; 

end;  {  of  output  microcode^field  } 

Procedure  generateNop; 
begin 

microcode^address  program_counter; 
writeln (outf ile, * ; * , prograra_counter , * :  Nop* ) ; 
output_microcode_field; 
prograra_counter  program_counter  +  1; 

end; 

Procedure  generate_ALU_operation (F,  R,  S : operand_type; opcode : longint) ; 
var  branch_field  :  array[1..4]  of  longint; 

begin  * 

{  store  the  branch  field  J 
branch_f ield [ 1 ]  am2910_opcode; 

br anch_f ield [ 2 ]  branch__opcoda; 

branch_field(3]  branch_address; 

branch_field  [  4  ]  :  -  branch_laokahead_buf f er  [  2 )  ; 

ara2910_opcode  cont; 

branch_opcode  0; 

branch_address  0; 

branch_loo)cahead_buffer [2]  no_branch; 

check_index_register (F,R,  S) ; 
check_pipeline__stage  (F,  R,  S,  opcode) ; 

{  restore  the  branch  field  ) 
am2910_opcode  branch_field[l] ; 

braneh_opcode  branch_field[2] ; 

branch_address  branch_field[3] ; 

branch_lookahead_buffer [2]  branch_field  (4} ; 

display_ALU_operation (F, R, S, opcode) ; 
bind_ALU_opcode (opcode) ; 
bind_AF_AR_AS (F, R, S) ; 
bind_AIF_AIR_AIS (F, R, S) ; 
microcode_address  prograra_counter; 
output_microcode_field; 
prograra_counter  prograra_counter+l; 
end;  {  of  generate_ALU_operation  } 

Procedure  check_F_bus (operand  :  operand_type) ; 
begin 

if  (write_lookahead__buf  fer [0] . id  <>  blank_token)  then 
if  (operand. id  -  write_lookahead_buf fer [0] . id)  then 

if  (operand. index  *  write_lookahead_buf fer [0] .index)  then 
if  (operand. offset  -  write_lookahead_buf fer (0) .offset)  then 
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generate_nop; 

if  (write_lookahead_buffer £0]  .id  O  blank_token)  then 
if  (operand. id  -  write^lookaheadjDuffer [0] .id)  then 

if  (operand. index  -  write_lookahead_buffer £0] .index)  then 
if  (operand. offset  -  write_lookahead__buffer  £  0J  .offset)  then 
generate_nop; 
end;  (  of  check_F_bus  ) 

Procedure  Clear_pipeline_stage; 
begin 

while  (write_lookahead_buffer£0] .id  <>  blank_token)  or 
(write_lookahead_buffer £1] .id  <>  blank_token)  do 
genera te_Nop; 

if  (AIR£QJ  <>  7fffH)  then  generate_nop; 
if  (AIS£0]  <>  7fffH)  then  generate_nop; 
if  (AIF£01  <>  7fffH)  then  generate_nop; 
end:  {  of  clear_pipeline_stage  } 

Procedure  load_index_register (index  :  token_type) ; 
var  integer^index  :  token_type; 
tl, t2  :  oper and_type ; 
index_pointer  :  longint; 
begin 

(  find  an  empty  index  register  } 
index_pointer  0; 

while  (index_pointer  <-  max_index_register)  and 

( index_regi st er (index_po inter 1  <>  blank_token)  do 

begin 

index_pointer  index_pointer+l; 
end; 

(  if  no  index  register  is  available,  flag  as  error  ) 
if  indexjpointer  >  max_index_register  then 

write_error( ' index  register  is  full  ' , blank_token) 

index_register £index__pointer]  index; 
if  (index  <>  blank_token)  and  <index£l]  <>  ’0r)  then 
begin 

assign_temp_variable (integer_index) ; 
reset_operand(t2) ; 
reset_operand (tl) ; 
t2.id  integer_index; 

tl.id  index; 

generate__ALU_operation (t2, tl,  zero_operand, unary_round)  ; 
clearj?ipeline_stage; 
delete ( integer_index,  1,1); 
val_integer (integer_index, AS, i) ; 

AR  AS; 

write (out file, f , program_counter. T  load  index_register £  * 

, index_pointer, ' ]  -  ’ ) ; 

write_token  (outfile,  index) ; 
write  (outfile,  MM  ; 

write_token (outfile,  integer_index) ; 
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writeln (out file, * ) * ) ; 

AIFflJ  index_pointer; 

AIS [1]  s-  index_po inter? 

AIR  1 1 J  ; -  index_po inter ; 

IA2  [2]  0? 

IA1  0; 

IA0  0; 

read_opcode  1? 

microcode^ address  prograra_eounter; 
output_raicrocode_f ield ; 
program_counter  prograra_counter+l; 
end; 

end;  {  of  load_index_register  } 

Procedure  check_index_register (var  F,R,S  :  operand_type) ; 

{  1.  check  existing  index  register 

2.  if  index  not  available,  load  required  indices  into  the  index  register  } 
begin 

R.index_address  assign_index  (R. index) ; 

S  ,index_address  :■*  assign_index(5. index) ; 

F.index_address  assign_index (F. index) ; 

end;  {  check_index_register  } 

Procedure  check_pipeline_stage  <var  F, R, S : operand_type; var  opcode : longint ) ; 
begin 

(  check  to  see  if  AIR[0]  and  AISfOJ  are  available  for  indexing  ) 
if  (AIRCO]  <>  7fffH)  or  (AlSfOl  <>  7fffH)  then  generate_nop; 

{  Note  that  F(k-2)  is  equivalent  to  vrite_lookahead_buffer (0] . 

Since  F(k-2)  is  not  available  on  the  R-port,  we  can  swap  R  and  S  operands 
with  proper  conditions:  } 
if  (opcode  -  unary jminus)  then 
begin 

svap_operand (R, S) ;  (  swap  R(k)  and  S(k)  } 

opcode  :•  subtraction; 

end;  (  of  swap  operand  if  operation  is  r^minus  or  unary_rainus  ) 

(  check  to  see  if  feedback  paths  can  be  used  for  calculation  } 

{  Case  1  ) 

(  R(k)  -  F(k-l)  } 

if  (R.id  -  write_lookahead_buffer (1] .id)  and 

(R. index  -  write_lookahead_buffer (1] .index)  and 
(R. offset  -  write_lookahead_buf fer [1] . of fset)  then 
begin 

{  Case  1.1  ) 

{  R (k)  -  S(k)  } 
if  (R.id  -  s .id)  and 

(R. index  -  S. index)  and 
(R. offset  -  S. offset)  then 
begin 

14  1; 


t 

I 

1 

I 

I 

t 

I 

i 

i 
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I3tl]  !-  1; 

S.id  blank_token; 

S.idtl]  ; 

S.id [2]  'S’; 

R.id  s-  blank_token; 

R. id[l] 

R. id [2]  'R* 

end 

else 

{  Case  1.2  > 

{  S 00  -  F(k-2)  > 

if  (S.id  -  write_lookahead_buffer [0] .id)  and 

<S. index  «  write^lookaheadjauffer [0] .index)  and 
(S. offset  -  write_lookahead_buffer [0] .offset)  then 
begin 

{  Case  1.2.1  } 

{  R(k)  is  a  temporary  variable  ) 
if  (R.idfll  -  »#*)  then 
begin 

S. id  blank_token; 

S.idtl] 

S.id[2]  fF’ : 

R.id  blank_token; 

R.id[l]  •-»; 

R.id [2]  s-  *R* ; 

ENF_bar  1; 

14  1; 

13  CH  1; 

end  {  of  1.2.1  } 
else 

{  Case  1.2.2  ) 

{  R(k)  is  a  permanent  variable  ) 
begin 

generate_nop;  {  make  R<k)  < —  F(k-2)  } 

{  Case  1.2. 2.1  > 

{  R(k)  and  S(k)  can  be  swapped  ] 
if  (opcode  -  multiplication)  or 
(opcode  -  addition)  then 
begin 

swap_operand(R, S) ;  {  swap  R(k)  and  S (k)  } 

S.id  blank_token? 

S.idtl] 

S . id [ 2 ]  s-  ' F * ; 

ENF_bar  1; 

13  Cl]  U 

end  {  of  1.2. 2.1  } 
else 

{  Case  1.2. 2. 2  } 

{  R(k)  and  S(k)  cannot  be  swapped  ) 
begin 

generate_NOP;  {  make  R  and  S  available  from  memory  } 
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end;  {  of  1.2. 2. 2  } 

end  {  of  1.2.2  R(k)  is  a  permanent  variable  ) 
end  {  of  1.2  S(k)  -  F(k-2)  } 
else 

(  Case  1.3  } 

{  S(k)  <>  F(k-l)  and  S(k)  <>  F(k-2)  } 
begin 

R.id  blank_token? 

R. id [1] 

R . id ( 2 ]  »R'; 

14  1; 

end;  {  of  (1.3)  R(k-l)  -  F(k-l)  and  S(k)  <>  F(k-2)  } 
end  {  of  (1)  R(k  -  F(k-l)  } 
else 

{  Case  2  ) 

(  S(k)  -  F(k-l)  } 

if  (S .id  -  write_lookaheadjDUffer [1] .id)  and  (  S(k)  -  F(k-l)  } 

(S. index  -  vrite_lookahead_buffer [11 .index)  and 
(S. offset  -  vrite_lookahead_buffer[l] .offset)  then 
begin 

{  Case  2.1  } 

{  R(k)  -  F (k-2)  ) 

if  (R.id  -  write_lookahead_buffer [0] .id)  and 

(R. index  -  write_lookahead_buf fer [0] .index)  and 
(R. offset  -  writ e_lookahead_buf fer (0) .offset)  then 
begin 

{  Case  2.1.1  } 

{  R(k)  and  S (k)  can  be  swapped  } 
if  (opcode  -  multiplication)  or 
(opcode  -  addition)  then 
begin 

{  Case  2. 1.1.1  ) 

{  S(k)  is  a  temporary  variable  } 

if  S.idtl}  -  then 

begin 

swap_operand(R, S) ;  {  swap  R  and  S  } 

S.id  blank_token; 

S.idU] 

S . id{2]  *F ' ; 

EHF_bar  1; 

13(1]  1; 

R.id  blank_token; 

R.idfl] 

R.id[2]  *R' ; 

14  s-  1; 

end  {  of  2. 1.1.1  } 
else 

{  case  2. 1.1. 2  ) 

{  S(k)  is  a  permanent  variable  } 
begin 

generate_nop;  {  make  R(k)  available  from  memory  and  S(k)  -  F(k-2)  } 
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S.id  blank_token; 
s.idfl]  ’-f; 

S.id[2]  *F* ; 

ENF_bar  1; 

13  [11  If 
end  (  of  2. 1.1.2  } 

end  {  of  2.1.1  R<k)  and  S<k)  can  be  swapped  ) 
else 

[  Case  2.1.2  } 

(  R  (k)  and  S(k)  cannot  be  swapped  ) 
begin 

generate_Nop;  (  make  S(k)  —  F(k-2)  1 
S.id  blank_token; 

s.idtH 

s.id[2]  *F ' ; 

ENF_bar  1; 

13  [11  1; 

end  {  of  2.1.2  > 
end  (  of  2.1  R<k)  -  F(k-2)  1 
else 

{  Case  2.2  } 

{  R(k)  <>  F (k-2  } 
begin 

I3[l]  1; 

S.id  blank_token; 

S.idtl]  »-*; 

S.id [2]  *S* ; 

end  {  of  2.2  ) 
end  {  of  2  S(k)  -  F(k-l)  } 
else 

{  R(k)  -  F (k-2)  1 

if  (R.id  -  write_lookahead_buffer [01 .id)  and 

(R. index  •  write_lookahead_buffer [01 . index)  and 
(R. offset  -  write_lookahead_buffer [0] .offset)  then 
generatejnop  {  make  R(k)  available  from  memory  ) 
else 

{  S (k)  -  F (k-2)  1 

if  (S.id  -  write_lookahead_buffer [0] .id)  and 

(S. index  -  write_lookahead_buffer [0] .index)  and 
(S. offset  -  write_lookahead_buffer [01 .offset)  then 
generate_nop  {  make  S (k)  available  from  memory  } 

end;  [  of  ckeck_pipeline_stage  ) 

procedure  display_ALU_operation(F,R, S  :  operand_type; opcode  :  longint) 
begin 

write ( out file r • ; • , program_counter, * ;  * ) ; 
write_token(outfile,F.id) ; 
if  F. index  <>  blank_token  then 
begin 


write (outfile, ' [ ' ) ; 
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write_token (out file, F. index) ; 
if  F. off set  >  0  then 

write (out file, •+• rF. offset, ’ J ') 
else 

if  F. offset  <  0  then 

write (outfile,F. offset, *] * ) 
else 

write (out file, • J f ) j 


end 

else 

if  F. off set  <>  0  then 

write (outfile, * [*,F. offset, *] ’); 
write (outfile, '  ’); 

write_token (outfile, R. id)  ; 
if  R. index  <>  blank_token  then 
begin 

write (outfile, *(’); 
write_token (outfile, R. index) ; 
if  R. offset  >  0  then 

write (outfile, *+* ,R. off set, * } f) 
else 

if  R. offset  <  0  then 

write (outfile, R. offset, ' ] ’) 
else 

write (outfile, * ) * ) ; 

end 

else 

if  R. offset  <>  0  then 

write (outfile, ' [*,R.offset, '} f ); 
case  opcode  of 

addition  :  begin 

write (outfile, *  +  *); 
end; 

subtraction  :  begin 

write (outfile, *  - 
end; 

multiplication  ;  begin 

write (outfile, *  *  •); 
end; 

unary_float  :  begin 

write (outfile, '  float  '); 
end; 

unary_round  :  begin 

write (outfile, '  round  '): 


unary_trunc 


r  minus  : 


end; 

:  begin 

write_error ( ’  truncation  is  not  supported 


,blank_tofcen) ; 

end; 

begin 

write ( outfile, •  -  *); 


I 

1 

I 

I 

1 

f 

I 

1 

I 

f 

1 

I 

1 
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end; 

or_operation :  begin 

write ( out f ile, *  or<+)  '); 
end; 

and_operation :  begin 

write (outfile, '  and(*)  ’); 
end; 

otherwise  begin 

writeln  (errorfile) ; 

write (errorfile, ’unsupported  real  operator  :  opcode); 

error_found 
end 

end;  {  of  case  opcode  } 
write_token( out file,s. id) ; 
if  S. index  <>  blank_token  then 
begin 

write ( outfile ,  * I ' ) ; 
write^token (outfile, s . index) ; 
if  S. off set  >  0  then 

write (outfile, ’  +  ’ ,  S. off set,  ' ] f ) 
else 

if  S. off set  <  0  then 

write (outfile, S. off set, * ] ') 

else 

write (outfile, * ] * ) ; 

end 

else 

if  S. off set  <>  0  then 

write (outfile, ' [ * ,S. offset, '  ]  ’ )  ; 
writeln (outfile) ; 

end;  {  of  display_ALU_operation  } 


procedure  bind_ALU_opcode (opcode : longint) ; 


begin 

case  opcode  of 


addition  ; 

mc325_buffer [1] 

0; 

subtraction  ; 

mc325Jbuffer (11 

It 

multiplication  ; 

mc325_buffer (1) 

2: 

unary_float  : 

rac325_buf f er ( 1 ] 

4; 

unaryjround  : 

mc325_buffer [1] 

j-  5; 

unary__trunc  ; 

write_error ( '  truncation  is  not  supported 

r_rainus  : 

mc325_buf f er [ 1 ] 

1; 

or_operation  : 

mc325_buffer Ill 

0; 

and_operation  ; 

mc325_buffer (11 

0; 

otherwise  begin 

writeln (errorfile) ; 

writeln (errorfile, 'unsupported  real  operator  ; 
error_found; 


,blank_token) ; 


' , opcode) ; 


end; 


end;  {  of  case  opcode  > 
end;  {  of  bind_ALU_opcode  } 

procedure  bind_AIF_AIR_AlS(F,R,5  :  operand_type) ; 

{  bind  the  instruction  fields  AIF,  AIR,  AIS  > 
begin 

if  (F. index  <>  blank_token)  and  (F. index [1]  <>  'O’)  then 
begin 

AIF [2]  F.  index__address; 

IA2{2]  1; 

end; 

if  (R. index  <>  blank__token)  and  (R. index [1]  <>  ’O')  then 
begin 

AIR ( 0 ]  R.index_address; 

IA1  1; 

end; 

if  (S. index  <>  blank_token)  and  (S.index[l]  <>  ’O’)  then 
begin 

AISfO]  S.index_address; 

IAO  1; 

end; 

end;  {  of  bind_AIF_AIR_AIS  } 

Procedure  bind_AF_AR_AS (F , R , S ; operand_type ) ; 
begin 

write_lookahead_buffert2]  s-  F; 
terap_token  :«  blank_token; 
add_char_to_string  (terap_token,  ’ ; 
if  (F.id(lJ  -  »#’)  or  (F.idtl]  -  ’«’)  then 
begin 

delete (F.id, 1, 1) ; 
val^integer <F.id,AFt2) ,i) ; 
end 
else 

if  F.id  -  temp_token  then 
AF 12 ]  ; -  stack_pointer 
else 

if  F.id 11]  <>  then 
begin 

find_symbol (F.id, symbol_type, symbol_value, found) ; 
if  not  found  then 

write_error( ’unknown  id  s  ’,F.id); 

if  symbol_value  <  0  then 
begin 

{  parameter  passing  call  by  value  } 

AIF [2]  abs(symbol_value)  -  1; 

IA2  [2]  1; 

AF (2 J  0; 
end 
else 

AFI2]  r-  symbol_value+F .offset 


I 

i 
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end; 

temp_token  blank_token; 
add_char_to_string  (temp_token,  ’ I’ ) : 
if  (R.idtU  -  '**)  or  (R.id[l]  -  '*’)  then 
begin 

delete (R.id, 1,1); 
val_integer {R. id, AR, i) ; 
end 
else 

if  R.id  -  temp_token  then 
AR  stackjpointer 
else 

if  R.id[l]  <>  then 

begin 

find  symbol (R.id, symbol^type, syrabol_value, found) ; 
if  not  found  then 

write_error { * unknown  id  :  ’,R.id) 

if  symbol^value  <  0  then 
begin 

{  parameter  passing  call  by  value  ) 

AIR(0]  abs (symbol_value) -1; 

IA1  1; 

AR  0; 

end 
else 

AR  syrabol_value+R. offset; 

end; 

temp_token  blank_token; 
add_char_to_string  (terap_token,  *  I*); 
if  (S.idtl]  -  ***)  or  (S.idtl]  -  *«’)  then 
begin 

delete (S. id,  1,1); 
val_integer (S.id,AS,i) ; 
end 
else 

if  S.id  -  terap_token  then 
AS  stack_pointer 

else 

if  s.idtl]  <>  then 
begin 

find_symbol(S.id, symbol_type, symbol_value, found) ; 
if  not  found  then 

write_error ( *  unknown  id :  * , S . id) ; 

if  symbol_value  <  0  then 
begin 

(  parameter  passing  call  by  value  ) 

AIS (0 1  abs (syrabol_value)  -  1; 

IA0  1; 

AS  0; 
end 


else 
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AS  :*■  syrabol_value+S.offset; 

end; 

end;  {  of  bind_AF_AR_and_AS  } 

{  Procedure  load_sequencer_counter (token :token_type) ; 
begin 

if  token  <>  '4'  then 

find_symbol (token, symbol_type, symbol_value, found) ; 
if  (symbol_type  <>  integer_symbol_type )  and 

( syrabol_type  <>  integer_constant_symbol_type)  and 
(token  <>  ’4’)  then 
begin 

write_error(* simple  integer  is  expected.  * .token) ; 

end; 

if  token  -  integer_lookahead_buffer £1]  then  generate_nop; 
if  token  -  integer_lookahead— buffer [0]  then  generate_nop; 
writeln(outfile, *;  load  sequencer  counter  :  ' , token); 

Dsel  1; 

AS  symbol_value; 

AR  AS; 

output_raicrocode_field; 
end;  ) 

Function  search_branch_address__pointer (expression  ;  expression_pointer) : longint; 
begin 
i  s-  1; 

while  (expression*. address (i]  <>  7fffH)  do  , 

begin 

i  s-  i+1; 

if  i  >  max_branch_pointer  then 
begin 

write_error ( ’maximum  branch  pointer  exceeded  token); 

end; 
end; 

search_branch_address_pointer  i; 
end;  {  of  search_branch_addre33_pointer  } 

Procedure  find_branch_address (var  expression  :  expression_pointer; 

var  branch_state  ;  longint); 

var  current_expression  ;  expression_pointer; 
address_found,hold_position  :  boolean; 
negation_state  :  longint;  {  even  :  no  negation 

odd  ;  require  negation  } 

change_branch_3tate  ;  longint;  {  even  :  no  change  of  branch  state 

odd  ;  require  change  of  branch  state  } 

(  branch_state  - >  1  -  branch  if  condition  is  true 

2  -  branch  if  condition  is  false 


3  -  true  and  false  address  jump  may  be  required 
(  last  boolean  expression  evaluated  ) 
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4  -  branch  if  condition  is  true 

5  -  branch  if  condition  is  false  } 

begin 

branch_state  0; 
negation_state  s-  0; 
change_branch_state  0; 
current_expre3sion  :«  expression; 
address_found  :«  false; 

{  find  the  branch  state  J 
repeat 

if  (current_expressionA .right  <>  nil)  then 
begin 

if  current_expressionA. right*. operator  -  or_operation  then 
branch_state  1 

else 

if  current_expression* .right*. operator  -  and_operation  then 
branch_state  2 

else 

if  eurrent_expression* .right* .operator  -  unary __not  then 
change_branch_3tate  change_branch_state  +  1 

else 
begin 

write  error {’error  found  in  generating  short  circuit  jump 
end; 
end; 

if  branch_state  -  0  then 
begin 

if  current_expression*.up  <>  nil  then 

cur r ent_expr e s s ion  current_expression* . up 

else 

if  current_expression* .left  <>  nil  then 
begin 

cur r ent_expre s s ion  current_expression* . left; 
if  {current_expressionA.id(lJ-,4* )  or 
(current_expression* . id  t 1 ] " ' %  * )  or 
(current_expression* . id [ 1 ] - ’ i ' )  then 
current_expression  current_expression* .up; 

end 

else 

branch_state  t-  3; 

end; 

until  <branch_state  >0); 

{  the  top  of  the  tree  has  reached  if  branch_state-3  } 

if  (branch_state-3)  then 

begin 

i  search_branch_address_pointer (current_expression) ; 

if  odd (change_branch_state)  then 

begin 

branch^state  :»  2; 

current_expression*. address [i]  (program_counter-l) ; 


' , token) 


end 
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else 

begin 

branch_state  :-2; 

current_expressionA.address[i3  - (program_counter-l) ; 

end; 

eurrent_expressionA.addrea3[i+l]  7fffH; 

{  writeln(outfile, 'First  gate  : - — ’ ) ; 

writeln(outfile,current_expressionA.id) ;  } 
end 
else 

{  find  the  branch  address  } 
begin 

negation_state  branch_state; 
repeat 

holdjposition  false; 
if  current_expressionA.up  <>  nil  then 

current_expression  current_expressionA.up 
else 

if  current_expressionA .left  <>  nil  then 
begin 

current_expression  eurrent_expressionA .left; 
if  (current_expressionA.idUJ-'*')  or 
( cur r ent_expr es s i on A . id ( 1 ] - ' % ' )  or 
(current_expr essionA . id ( 1 ] - ’ i » )  then 
current_expression  current_expressionA . up 
else 

holdjposition  true; 

end 

else 

branch_state  branch_state+3 ; 

if  current_expressionA. right  <>  nil  then 
begin 

if  (odd(negation_state)  and  {current_expressionA . rightA .operator-and_operation) )  or 

(not  odd(negation_state)  and  (current_expressionA.rightA .operator«or_operation) )  then 
begin 

current^expression  :«  cur rent_expressionA .right; 

if  not  hold_position  then 

begin 

while  (current_expressionA .down  <>  nil)  do 
begin 

current_expression  current_expressionA.down; 
while  (current_expressionA .down  <>  nil)  do 

current_expres3ion  current_expressionA .down; 

if  (current_expressionA. right  <>  nil)  then 

current_expression  i-  current_expressionA. right; 

end; 

end; 

i  search_branch_address_pointer (current_expression) ; 
current_expressionA .address [i+1]  7fffH; 
current_expre33ionA .address (il  prograrc_counter-l; 
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address_found  true; 

{  writeln (out file, f Second  gate  :  - 

write In  < out file, current_expression* . id) ;  } 
end 
else 

if  (current_express ion*. right*, operator  -  unary _not)  then 
negation_state  negation_state+l; 

end; 

until  <address_found)  or  (branch_state>2) ; 

if  (branch_state>2)  then 

begin 

branch_state  :■  branches t at e-3; 
negation_state  s-  negation_state  +  1; 

i  search_branch_address_pointer(current_expression) ; 

if  odd(negation_state)  then 

current_expression*. address [i]  :•  -(program_counter-l) 

else 

current_expression*. address [i]  s-  prograra_counter-l; 
current^expres sion*. address ti+1]  7fffH; 

{  writeln (outfile, 'Third  gate  ;  - '); 

writeln (out file, current_expression* . id) ;  } 
end; 

if  odd (change_branch_state)  then 
begin 

if  branch_state  -  1  then  branch_state  :•  2 
else  branch_state  1; 

end; 

end; 

end;  {  of  find_branch_address  } 

procedure  generate_boolean_assignment_microcode (var  expression  i 

expression_pointer; 
branch_true  :  boolean) ; 

var  F,R,S  s  operand_type; 
begin 

reset_operand (R) ; 
reset^operand (S) ; 

if  (branch__true)  then  str_real (0 . 0,  R.id)  else  str_real (1 . 0,  R.id) ; 
str_real(0.0,S.id) ; 
am2910_opcode  CJP; 

br anch_lookahead_buf  f er ( 0 ]  unconditional; 

branch_address  program_counter+2; 

F.id  expression*. left*. up*. id; 

F. index  expression* .left* .up* .index; 

F. offset  expression* .left*. up*. off set; 
generate_ALU_operation (F, R, S, addition) ; 

if  (branch_true)  then  str_real (1 . 0,R. id)  else  str_real (0.0,R.id) ; 
generate_ALU_operation<F, R, S, addition) ; 
end;  (  of  generate  boolean__assignment_raicrocode  ) 

Procedure  generate_branch_address (var  expression  :  expression_pointer) ; 
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var  branch_true  :  boolean; 

i  ;  integer? 
begin 

if  expression* .address [1]  <>  7fffH  then 
begin 

while  (branch_lookaheadJbuffer [0]  <>  7fffH)  or 
(branch_lookahead_buffer[l]  <>  7fffH)  do 
generate_Nop; 
i  1; 
repeat 

writelntoutfile, 'b  abs (expression* .address {i] )  +2,  *  ' , program_counter) ; 
expression*. address [ij  7fffH; 

i  i+1; 

until  expression*.address [i]  -  7fffH; 
end; 

if  (expression*. left*. up*. up-nil)  and 
(expression* . left* . up* . left-nil)  then 
begin 

if  (expression*.left*.up*.id[l]  <>  *#')  and 

(expression*. left*. up*. address(l]  <>  7fffH)  and 
(  ( ((expression*. left*.id[l ]-'*’)  or 

(expression* . left* . id-blank_token) )  and 
( (expression*. id[l]-’*»)  or  (expression* . id-blank_token) ) )  or 
( (expression*. left*. idtljo**’)  and  (expression*.idtl]<>,#,))  )  then 

begin 

while  (branch_lookahead_buf fer [0]  <>  7fffH)  or 
(branch_lookahead_buffer [1]  <>  7fffH)  do 
generate_Nop; 

i  ;-  search_branch_address_pointer (expression*. left*. up) ; 
if  (expression*. left*. up*. address (i-1 I >0)  then  branch_true  true 

else  branch_true  :-  false; 

i  1; 
repeat 

if  (branch_true)  then 
begin 

if  expression*. left*. up*. address [i]  >  0  then 

writelntoutfile,  *b  expression* .left* .up* . address [i] +2, ’  * , program_counter+l) 
else 

writelntoutfile,  rb  ? , abs (expression* .left* .up* .address [i] ) +2, '  * , program^counter) ; 

end 

el3e 

begin 

if  expression*. left*. up*. address (i]  >  0  then 

writelntoutfile, *b  ’ .expression*. left*.up*. address (i] +2, •  »,program_counter) 
else 

writelntoutfile, ’b  *, abs (expression* . left* .up* . address [i] ) +2, *  *  ,prograin_counter+l) ; 

end; 

expression*. left*. up*. address[i]  7fffH; 
i  i+1; 

until  (expression*. left*. up*. address [i]  -  7fffH); 
if  (branch_true)  then 
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generate_boolean_ assignraent_microcode (expression, true) 

else 

generate_boolean_assignraent_microcode (expression,  false) ; 

end; 

end; 

end;  {  of  generatejaranch_address  } 

procedure  swap_operand(var  R,S:operand_type) ; 

var  temp  ;  operand_type ; 

begin 

temp  R; 

R  S; 

S  temp; 

end;  (  of  procedure  swap_operand  } 

procedure  assign_tempJx>olean_variable (var  F  :  operand_type) ; 
begin 

str_integer (dataram_address_lirait-temp_variable_lirait,  F . id) ; 

terap^token  blank_token; 

teinp_token[l) 

concat  (terap_token,  F.id); 

F.id  terap_token 

end;  {  of  aasign_temp_boolean_variable  } 

procedure  generate_greater_than (var  expression  :  expression_pointer) ; 
var  F,R,S  ;  operand_type ; 

opcode, branch_st ate  :  longint; 
begin 

fetch_expression (F, R, S, expression) ; 
swap__operand  (R,  S) ; 
opcode  expression'* .operator ; 
check  jpipeline_stage (F,R, S, opcode) ; 
generate_branch_address (expression) ; 
as3ign_temp_boolean_variable (F) ; 
generate_M.U_operation  (F,  R,  S,  subtraction) ; 
find_branch_address  (expression*. left*. up, branch_state)  ; 
if  branch_state  -  1  then 

branch_lookahead_buf f er I 1 1  : -  if ^negative 
else 

branch_lookahead_buf f er [ 1 )  if_not_negative; 
generate_branch_address (expression) ; 
end;  (  of  generate_greater_than  ) 

procedure  generate_less_than(var  expression  :  expression_pointer) ; 
var  F,R,S  :  operand_type; 

opcode, branch_state  :  longint; 
begin 

fetch_expression (F, R, S, expression) ; 
opcode  expression* . operator; 
check_pipeline_stage (F, R, S, opcode) ; 
generate_branch_address (expression) ; 
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a8sign_temp_boolean_variable (F) ; 
generate_ALU_operation (F, R, S, subtract ion) ; 
find_branch_address (expression*, left*, up, branch_state) ; 
if  branch_state  -  1  then 

branch_lookahead_buffer (1]  if_negative 

else 

branch_lookahead_buffer £1]  if_not_negative; 

generate_branch_address (expression) ; 
end;  (  of  generate_less_than  ) 

procedure  generate__equal  (var  expression  ;  expression_pointer) ; 
var  F, R, s  ;  operand_type; 

opcode, branch_st ate  :  longint; 
begin 

fetch_expression (F,R, S, expression) ; 
opcode  expression* .operator; 
cheek_jiipeline_stage (F, R, S, opcode) ; 
generate_branch_address (expression) ? 
assign_temp_boolean_variable (F) ; 
generate_AHJ_operation (F, R,S, subtraction) ; 
find_branch_address (expression*. left*. up, branch_state) ; 
if  branch_state  -  1  then 

branch_lockahead_buffer £1]  i-  if_zero 
else 

branch_lookahead_buffer £11  if_not_zero; 
generate_branch_address (expression) ; 
end;  (  of  generate_equal  ) 

procedure  generate__not_equal(var  expression  ;  expression_pointer) ; 
var  F, R, S  :  operand_type; 

opcode, branch_st ate  :  longint; 
begin 

fetch_expression (F,R, S, expression) ; 
opcode  expression* .operator; 
eheck_pipeline_stage (F, R, S, opcode) ; 
generate_branch_address (expression) ; 
assign_temp_boolean_variable(F) ; 
generate_ALU__operation  (F,  R,  S,  subtraction) ; 
find_branch_address (expression* . left* . up, branch_state) ; 
if  branch_state  -  1  then 

branch_lookahead_buffer£ll  if_not_zero 

else 

branch_lookaheadJbuffer £1]  if_zero; 

generate_branch_address (expression) ; 
end;  {  of  gene rat e_not_e qua 1  } 

procedure  generate_greater_than_or_equal (var  expression  ;  expression_pointer) ; 
var  F,R, S  :  operand_type; 

opcode, branch_state  ;  longint; 
begin 

fetch_expression (F, R, S, expression) ; 
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opcode  !-  expression*. operator; 
check__pipeline_stage  (F,R,S, opcode) ; 
generate^ branch^address (expression) ; 
assign_temp_boolean_variable (F) ; 
generate_ALU_operation (F,R, S, subtraction) ; 
find_branch_address (expression* . left* .up, branch_state)  ; 
if  braneh_state  -  1  then 

branch_lookahead_buffer [1]  s-  if_not_negative 
else 

br aneh_lookahead_buf f er [ 1 ]  s-  if_negative; 
generate_branch_address (expression) ; 
end;  (  of  generate_greater_than_or_equal  } 

procedure  generate_less_than_or_equal (var  expression  :  expression_pointer) ; 
var  F,R,S  :  operand_type; 

opcode, branch_state  :  longint; 
begin 

fetch_expression (F, R, S, expression) ; 
swap_operand (R ,  S) ; 
opcode  expression* .operator; 
check  _pipeline_st age (F, R, S, opcode) ; 
generatejsranch__address  (expression)  ; 
assign_temp_boolean_variable (F) ; 
generate_ALU_operation (F, R, S, subtraction) ; 
find_branch_address (expression* .left* .up, branch_state) ; 
if  branch_state  -  1  then 

branch_lookahead_buf f er 1 1 ]  if_not_negative 

else 

branch_lookahead_buf fer [1]  if_negative; 

generate_branch_address (expression) ; 
end;  {  of  generate_less_than_or_equal  } 

Procedure  generate_unary_not (var  expression  :  expression_pointer) ; 
var  F,R,S  ;  operand_type; 

opcode, branch_state  :  longint; 
begin 

fetch_expression(F,  R,  S,  expression) ; 
opcode  expression*. operator: 
if  R.id(l]  -  •*'  then 
begin 

generate_branch_address (expression) ; 
end 
else 
begin 

if  f.id[l]  -  then 
begin 

reset_operand(S) ; 
str_real ( 0 . 0 , S . id) ; 

check_pipeline_stage (F,R,S, opcode) ; 
generate_branch_address (expression) ; 
assign_temp_boolean_variable (F) ; 
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generate_ALU_operation(F,R, S, addition) ; 
find_branch_address  (expression-- . left* .up,  branch_state) ; 
if  branch_state  -  1  then 

branch_lookahead_buffer [1]  if_zero 

else 

branch_lookahead_buffer [1]  if_not_zero; 

generate_branch__address  (expression) ; 
end 
else 
begin 
S  R; 

reset_operand (R) ; 
atr^real (1 . 0, R. id) ; 

generate_ALU_operation (F,R, S, subtraction) ; 
end; 
end; 

end;  (  of  generate_jinary_not  } 

procedure  generate_and(var  expression  ;  expression_pointer) ; 
var  F,R,S  :  operand_type: 

branch_st ate, opcode  :  longint; 
begin 

fetch_expression(F,R,S, expression) ; 
if  ((S.idtl)  <>  ’#*)  and 
(R.idtU  <>  **•))  then 
begin 

if  (F.id(ll-,*'>  then 
begin 

opcode  multiplication; 
check_pipeline_stage (F,  R, S, opcode) ; 
generate_branch_address (expression) ; 
assign_temp_boolean_variable (F) ; 
generate_ALU_operation  <F, R, S, opcode) ; 

find_branch_address  (expression-. left*-. up, branch_3tate) ; 
if  branch_state  -  1  then 

branch_lookahead_buffer [1]  if_not_zero 

else 

branch_lookahead_buffer 11]  if_zero; 

end 

else 

generate_ALU_operation (F,R, S, multiplication) ; 

end 

else 

if  (R.idUl  -  ’#»)  and  (S.idtl)  -  '*’)  then 
begin 

generate_branch_address (expression) ; 
end 
else 

if  (R.id[l]  -  ’*•)  then 
begin 


opcode  addition; 
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,tr_real (0 . 0, R.id) ; 

check_pipeline_stage  (F,  R,  S,  opcode) ; 
generate_branch_address (expression) ; 
assign_temp_boolean_variable(F) ; 
generate_ALU_operation (F, R, S, opcode) ; 

find_branch_address (expression* . left* .up, branch_state) ; 
if  branch_state  -  1  then 

branch_lookahead_buffer(l]  :•  if_not_zero 
else 

branch_lookahead_buffer [11  if_zero; 
expression*. id [11  ,*t; 

gener at e_branch— address (expression) ; 
end 
else 

if  (S.id[ll  -  ’#')  then 
begin 

opcode  addition; 
str— real (0.0,3. id) ; 

check _pipeline_stage (F, R, S , opcode) ; 
generate_branch__address  (expression) ; 
assign_temp_boolean_variable(F) ; 
generate_ALU_operation(F, R, S, opcode) ; 

find_braneh_address (expression* .left* .up, branch_state) ; 
if  branch^state  -  1  then 

branch_lookahead_buf fer (1 J  if_not_zero 

else 

branch_lookahead_buffer [11  if_^zero; 

expression*. left*. id [1]  ***; 

generate_branch_address (expression) ; 
end; 

end;  (  of  generate_and  ) 

procedure  generate_or (var  expression  :  expression_pointer) ; 
var  F, R, 5  :  operand_type; 

branch_state, opcode  :  longint; 
begin 

fetch_expression (F, R, S, expression) ; 
opcode  addition; 
if  ( (S . id(l]  <>  '*')  and 
(R.id[l]  <>  '♦’)>  then 
begin 

checkjpipeline_stage (F,R,S, opcode) ; 
generate_branch_address (expression) ; 
assign_temp_boolean_variable (F) ; 
generate_ALU_operation (F,  R, S,  opcode) ; 

find_branch_address (expression* . left* .up, branch_state) ? 
if  branch_state  -  1  then 

branch_lookahead_buffer [1]  :»  if_not_zero 

else 

branch_lookahead_buffer [1]  if_zero; 
expression* . id [1] 
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expression* . left* . id ( 1 )  *#♦; 

generate_branch_address  (expression) ; 
end 
else 

if  (R.id(l)  -  ♦#*)  and  (S.id[l]  -  **')  then 
begin 

generate_branch_address (expression) ; 
end 
else 

if  (R.idtl]  -  »*•)  then 
begin 

str_real(0.0,R.id) ; 
checJcjpipeline_stage(F,R,  S,  opcode)  ; 
generate_branch_address (expression) ; 
assign__terap_boolean_variable(F) ; 
generate_ALU_operation <F, R, S, opcode) ; 
find_branch_address (expression* .left* . up, branch_state) ; 
if  branch_state  -  1  then 

branch_lookahead_buffer [1]  if_not_zero 

else 

branchy loo)cahead_buffer (I)  if_zero; 

expression*. id [1]  **'; 

generate_branch_address (expression) ; 
end 
else 

if  (S.id[l]  -  »#*)  then 
begin 

str  jreal ( 0 . 0 , S . id) ; 
check_pipeline_stage(F,R, S, opcode) ; 
generate_branch_address (expression) ; 
assign_temp_boolean_variable(F) ; 
generate__ALU_operation  (F,  R,  S,  opcode) ; 

find_branch_address (expression* -  left* .up, branch_state) ; 
if  branch^state  -  1  then 

branch_lookahead_buffer  [1]  if_not_zero 

else 

branch_lookahead_buffer [1]  if_zero; 

expression*. left*. id (1)  *#’; 

generate_branch_address (expression) ; 
end; 

end;  {  of  generate_or  ) 

function  assign_index (index  :  token_type) : longint; 

var  index_pointer  ;  longint; 

begin 

if  index  <>  blank_token  then 
begin 

index_pointer  0; 

while  (index_pointer  <-  max_index_register)  and 

(index  <>  index_register {index_pointer] )  do 


begin 
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index _pointer  index_pointer+l; 

end; 

if  index_pointer  >  max_index_register  then 
begin 

load_index_register (index) ; 
index_po inter  assign_index (index) ; 

end; 

assign^index  index^pointer; 

end 
else 

assign_index  0; 

end;  {  of  assign_index  ) 

Procedure  generate_read_function(function_number  ;  longint; 

f x, x  :  operand_type) 

begin 

find_syrabol (fx.id, fx. id_type, fx. id_address, found) ; 
if  not  found  then 

write_error( ’unknow  id:  *,x.id) 

fx. index_address  assign_index(fx.index); 

find_symbol(x.id,x.idJ:ype,x.id_addreas,  found) ; 
if  not  found  then 

write_ error ( 'unknow  id:  *,x.id) 

x.index^address  :■*  assign_index (x. index) ; 
cl e ar_p i pe line_stage ; 
terap_token  : —  blank_token; 
operand_string ( fx,  terap_token) ; 
write  (outfile,  * ;  read_function  ( * ) ; 
write_token (out file, temp_token) t 
write  (outfile,  ’,*); 
temp_token  blank_token; 
operand_string  ( x,  temp__token)  ; 
write_token  (outfile, temp_token) ; 
writeln  (outfile,  ’)’); 
microcode_address  prograra_counter; 

AR  x.id_address  +  x. offset; 

if  (x. index  <>  blank_token)  and  (x. index [1]  <>  *0’)  then 
begin 

AIR [0]  x.index_address; 

IA1  1; 

end; 

AS  AR; 

IA0  IAl; 

output _raicrocode_field ; 
prograra_counter  :•  program_counter  +1; 
raicrocode_address  :•  program_counter; 

AF(0]  fx.id_address  +  fx. offset; 

if  (fx. index  <>  blank_token)  and  (fx.index(l]  <>  'O’)  then 
begin 


AIF(0]  fx. index__address; 

IA2  [ 0)  1; 
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end; 

write^opcode  read_function_opcode  +  function_numi>er; 
output_microcode_field; 
program_counter  prograra_counter  +  1; 
end;  {  of  generate_read_f unction  ) . 
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File:  COMPILER. PAS 
module  Compile; 

Sinclude (global . def ) 

$include (hex_conv . def) 

^include ( ieee_cnv . def) 

$include (utility. def) 

^include (init . def) 

^include ( f et ch_tk . def ) 

$include ( symbol_t . def) 

$include i code_gen .def) 

$include (expr sion . def ) 

$inelude (exprtree . def) 

^include (declare . def) 

^include (io . def) 

^include ( a  r ith .def) 

^include ( stdprocd . def) 

$ include (mainbody . def ) 

$include (erau_lib. def) 

program  Compile  (input,  output) ; 
begin 

initialize; 

(  program  heading  } 
fetch_token; 

if  token  <>  program_heading  then 
begin 

writeln (errorfile) ; 

writeln(errorfile, * ! !! I  syntax  error  :  program  heading  expected*); 

error_found; 

end 

else 

prograra_heading_block; 
fetch— token; 
pr ogr am_ma in_block ; 
if  (token [1]  <>  *.*)  then 
begin 

writeln (errorfile) ; 

writeln (errorfile,  *!!! 1  syntax  error  :  is  expected*); 

error_found; 

end; 

if  program_counter  >  prograra_counter_lirait  then 
begin 

writeln(errorfile) ; 

writeln (errorfile, ' ! ! l(  Program  is  too  long.  Limit  is  * , program_counter_limit, ' . * ) ; 

writeln (errorfile, *  Current  program  size  is  * , program_counter, * . * ) ; 

error_found; 
end; 

clear_pipeline_stage ; 
raicrocode_addres3  prograra_counter; 
writeln  (out file,  *;  '  ,program__counter,  *  : 


goto  * , program_counter)  ; 
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am2910_opcode  s-  CJP; 

branchy opcode  unconditional; 

branch_addresa  program__counter; 

output_microcode_field; 

writeln; 


end. 
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Pile:  DECLARE. DBF 
public  declare; 

procedure  type_declaration_bloc)c; 
procedure  var_declaration_block; 
procedure  const^declar ation_block ; 

Procedure  aasign_real_constant (var  operand :operand_type; value  :  real); 
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File:  DECLARE. PAS 
module  declare; 

§ include (declare. def) 

$ include (emu_lib.def ) 

$ include (global .def ) 

$ include ( fetch_tk . def) 

Sinclude (utility .def) 

^include ( 3ymbol_t . def) 

private  declare; 

procedure  type_declaration_block; 
begin 

writeln(errorfile) ; 

writeln(errorfile, * ! ! ! !  error  :  general  type  is  not  supported  yet.’) 
error_found; 
end; 

procedure  var_declaration_block; 
var  i.j  :  longint; 

var__type  :  longint; 
begin 
i  0; 

fetch_token;  {  variable  name  ) 
repeat 
i  i+1; 

syrabol_array (i)  :«•  token;  (  insert  token  to  symbol  array  }; 
fetch^token;  (  ,  } 
while  token  -  comma  do 
begin 

fetch_token:  {  variable_name  }; 
i  i+1; 

.  symbol_array [i]  token;  (  insert  token  to  symbol  array  }; 

fetch_token; 

end; 

verify_token (token. colon) ; 
fetch_token;  {  variable_type  ) 
if  (token  -  real_token)  then 
begin 

var_type  : -  real_syrabol_type; 
end 
else 

if  (token  -  integer_token)  then 
begin 

var^type  integer_symbol_type; 
end 
else 

if  (token  -  boolean_token)  then 
begin 

va retype  :«  boolean_symbol_type; 


end 
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•lse 

if  (token  -  array_token)  then 
begin 

fetch_token;  (  I  } 

verify_token (token, open_square_bracket) ; 

fetch_token;  {  constant  } 

terap_token  blank_token; 

terap_token(l]  * f 

if  token  -  temp_token  then 

begin 

fetch__token; 

array_lower_range  :•  -1: 
end 
else 

array_lover_range  1; 

if  symbol_type  -  integer_constant_symbol_type  then 
begin 

array_lower_range  integer_constant_value*array_lover_range; 

end 
else 
begin 

find_syrabol (token, syrabol_type, symbol_value, found) ; 
if  symbol_type  -  integer_constant_symbol_type  then 

array  lower_range  integer_constant_value*array_lower_range 
else 
begin 

vrite_err or ('integer  constant  expected 
end; 

fetch_token;  (  .  ) 
verify_token (token,  dot) ; 
end; 

fetch_token;  {  .  ) 
verify_token (token,  dot) ; 
fetch_token;  {  constant  } 
if  token (11  -  then 
begin 

fetch_token; 

array _upper_range  -1; 

end 

else  array_upper_range  1; 

if  syrnbol^type  -  integer_constant_symbol_type  then 
begin 

array_upper_range  integer_constant_value*array_upper__range; 

end 
else 
begin 

find_symbol (token, symbol_type, symbol_value, found) ; 
if  symbol_type  -  integer_constant_symbol_type  then 

array  upper_range  integer__constant_value*array_upper_range 
else 
begin 


’, token) ; 
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write_error( * integer  constant  expected  * , token) ; 

end; 
end; 

fetch_token;  {  ]  } 

verify_token  (token,  close_square__bracket) ; 

fetch^token;  (  of  ) 

verify_token (token, of_ token) ; 

fetch_token;  {  real  } 

if  token  -  real_token  then 

begin 

var_type  real_array_syrabol_type; 

end 
else 

if  token  -  integer_token  then 
begin 

var_type  integer_array_symbol_type; 

end 
else 

if  token  -  boolean_token  then 
begin 

var_type  boolean_array_symbol_type ; 

end 
else 
begin 

write_error (* Unsupported  array  type  * , token); 

end; 
end 
else 
begin 

write_error (' syntax  error  :  unsupported  type  token); 

end; 

fetch_token;  {  ;  ) 
verify_token (token, semicolon) ; 
for  j  i  downto  1  do 
begin 

insert_syrabol (syrabol_array t  j  ] , var_type , symbol_value ) ; 

no_loca levari able [procedure_level]  :*  no_loca Invariable [procedure^level] +1; 
local_variable[procedurenlevel,no_localnVariable[procedurenlevel] ]  symbol_array ( j J ; 
{  writeln (out file, * symbol_value  :  * , symbolnValue) ; 

writeln (outfile, 'lower  range  :  ' , array_lower_range) ; 
writeln (out file, 'upper  range  :  ’ , array_upper_range) ; 
writeln  (out f ile,  'datarain_address  s  *  ^ataram^address) ;  ) 

end; 
i  0; 
fetch_token; 

until  (  token  -  begin__token  )  or  (token  -  const_declaration)  or 
(  token  -  function_heading  )  or 
(  token  -  procedure_heading) ; 
end;  {  of  var_declaration_block  ) 

procedure  const_declaration_block; 


Digital  Emulation  Technology  Laboratory  Final  Report 


97 


var  constant_name  j  token_type; 

invert_constant_value  :  boolean; 
begin 

fetch_token; 

repeat 

invert_constant__value  false; 
constant_narae  token; 
fetch_token; 

verify_token (token, equal_token) ; 
fetch_token;  {  constant  value  } 
if  token  -  truest oken  then 
begin 

str— real (1.0, token) ; 
real_ constant__value  :  ••  1.0; 

symbol_type  boolean_constant_symbol_type; 

end 
else 

if  token  -  false_token  then 
begin 

str_real  (0.0,  token ) ; 
real_constant_value  0; 

symbol_type  boolean_constant_syrabol_type; 

end 
else 

if  token[l]  -  then 
begin 

fetch_token; 

terap_token  blank_token; 
terep_token[l] 
concat (temp_token, token) ; 
token  terap_token; 
invert_constant_value  true; 
end 
else 

if  token (1)  -  ' +  ’  then 
begin 

fetch_token; 

end 

else 

if  (symbol_type  <>  real_constant_syinbol_type)  and 

(symbol_type  <>  integer_constant_symbol_type)  then 
begin 

find_symbol  (token,  syinbol^type,  symbol_value,  found)  ; 
end; 

if  (syrabol_type  <>  real_constant_symbol_type)  and 

(symbol_type  <>  integer_constant_symbol_type)  then 
begin 

write_error( ’invalid  or  unsupported  constant  * , token) ; 

end; 

if  invert_constant_value  then 
begin 
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real_constant_value  s-  -real_constant_value ; 
integer_constant_value  -integer_constant_value; 
end; 

insert_symbol (const ant_name,  symbol_type,  symbol^value) ; 

no_local_variablelprocedure_level]  s-  no_local_variable{procedure_level] +1; 
local_variable  tprocedure__level,no_local_variable[procedure_level]  ]  constant_name 
declare^constant  (symbol_value,  symbol_type,  constant_name)  ; 
fetch^token; 

verify_token  (token,  semicolon) ; 
fetch_token; 

until  (  token  -  begin_token  )  or  (token  -  var^declaration)  or 

(  token  -  procedure_heading)  or  (  token  »  function_heading  )  or 
(  token  -  const_declaration  ) ; 
end;  (  of  const_declaration_block  } 

Procedure  assign_real__constant (var  operand : operand_type; value  :  real); 

(  This  procedure  is  used  to  declare  a  constant  real  number. 

It  is  used  to  simplify  a  declaration  of  constant  with  real  number. 

It  is  primarily  used  to  aid  the  development  of  standard  function  calls. 

) 

begin 

reset_operand (operand) ; 
str_real (value, operand. id) ; 

operand . id_type  real_constant_symbol_type; 
real_constant_value  :«  value; 

find_syrabol (operand. id, operand. id^type, operand. id_address, found) ; 

if  not  found  then 

begin 

insert_symbo 1 ( operand . id , operand . id_type , operand . id_addre  s  s ) ; 
declar e_const ant (operand. id_address, operand. id_type, operand. id) ; 
end; 

end;  {  of  assign_real_constant  } . 
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Files  EMU_LIB.DEF 
public  emu_lib; 

procedure  dearscreen; 
procedure  gotoxy  (x,y  : longint); 

procedure  *tr_integer  (  int eger_numbe r  :  longint;  var  token  :  token_type) 
procedure  str_real  (  x  :  real;  var  token  :  token_type) ? 
procedure  val_real  (  token  :  token_type;  var  real_number  :  real; 

var  error_integer  :  longint); 
procedure  val_integer  (  token  :  token_type;  var  number  : 

longint;  var  error_integer  s  longint) ; 
function  length  (  token  :  token_type  )  :  longint; 
procedure  add_ehar_to_string  (  var  token  :  token_type;  x  :  char) ; 
procedure  concat  (var  tokenl  :  token_type;  token2  :  token_type) ; 
procedure  delete  (var  token  :  token__type;  index,  counter  :  longint) ; 
procedure  read_token  (  var  token  :  token_type) ; 
procedure  write_token  (var  x  :  text;  token  :  token_type) ; 


Digital  Emulation  Technology  Laboratory  Final  Report 


File:  BMU_LI B . PAS 
nodule  emu_lib; 

^include (ereu_lib.def) 

$ include (global . def ) 

$ include (utility .def) 

private  erau_lib; 

procedure  clearScreen; 
begin 

write (chr (27) , ' [2J* ) ; 
end; 


function  length  (  token  :  token_type  )  :  longint; 
var 

i  :  longint; 
begin 

i  1; 

while  (token [i]  <>  ’  * )  and  (i  <  max_token_length)  do 
i  i  +  1; 

if  token [raax_token_length]  <>  *  *  then 
length  raax_token_length 

else 

length  i  -  1 
end;  {  length  ) 

procedure  delete  (  var  token  :  token_type;  index,  counter  :  longint) ; 
var 

i,j,l,x  :  longint; 
begin 

if  (index  <  1)  or  (counter  <  0)  then 

write_error  (’Parameters  to  procedure  delete  out  of  range. 

blank_token) 

else 

if  index  <-  raax_token_length  then 
begin 

j  1; 

i  index; 

1  length (token) ; 

while  (i  <-  max_tokenJLength)  and  (i  <  (index  +  counter) )  do 
begin 

for  x  index  to  (1  -  j)  do 
token [x]  token [x  +  1]; 

if  (j  -  1)  and  (i  -  index)  then 
token[l]  *  * 

else 

j  j  +  1: 

i  i  +  1; 

end 
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end 

end;  (  delete  } 


procedure  gotoXY(x,y  : 

longint) ; 

begin 

if  x>80  then  x  80; 

?  if  x<l  then  x 

if  y>24  then  y  24; 

r  if  y<l  then  y 

write (chr (27) , * [ ’ , y, 1 

»,x, ’H’) ; 

end; 


{procedure  pad_with_spaces  (  var  string  :  token_type;  a.b  ;  longint); 

var 

x  :  longint; 

begin 

for  x  :•  a  to  b  do 
string [xj  ’  ’ 
end;  pad_with_spaces  } 


procedure  add_char_to_string  (  var  token  :  tokenJ:ype  ;  x  i  char  ); 

var 

i  s longint; 

begin 

i  1; 

while  (tokenfi]  o’  *)  and  (i  <-  max_token_length)  do 
i  1  +  1; 

if  i  >  raax_token_length  then 
write_error  { ’token  too  long 

else 

token {i]  x 

end;  {  add_char_to_string  } 


procedure  concat  (  var  tokenl  :  token_type  ;  token2  :  token_type) ; 
{  Append  as  much  of  token2  onto  tokenl  as  possible  } 


var 

i,  j  :  longint; 


begin 

j  1; 

i  length  (tokenl)  +•  1; 

while  (i  <-  max_token_length)  and  (token2{jj  <>  ’  ’)  do 


token) 


begin 
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tokenl [i]  s-  token2[j]; 
i  i  +  1; 

j  j  +  1 

end; 

end;  {  concat  } 


{procedure  str_integer  {  x  :  real;  var  string  :  token_type) ; 
var 

i,  j,  k  :  longint; 
integer_number  :  longint; 
temp_char  :  char; 

begin 

string  blank__token; 
i  1; 

j  1; 

if  x  -  0.0  then 
begin 

k  2; 

stringtl]  *0* 

end 

else 

begin 

if  x  <  0.0  then 
begin 

string {i] 
i  *-  i  +  1 
end; 
j  =-  i; 

integer_nuraber  abs {ltrunc(x) ) ; 

while  integer__number  >  0  do 
begin 

stringfi]  chr  { (integer_number  mod  10)  +  30H) ; 

integer_nurober  integer_number  div  10; 
i  i  +  1 
end; 
k  i; 
i  r-  i  -  1; 
while  j  <  i  do 
begin 

Temp_Char  :«•  stringfi); 
string [i]  string [j); 

string [j]  temp_char; 

j  «-  j  +  1*' 

i  i  -  1 


end 
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end 

end;  str_integer  } 

procedure  str_integer  (  integer_number  :  longint;  var  token  :  token_type) ; 
var 

i,  j,  k  s  integer; 
temp__char  :  char; 

begin 

token  blanket oken; 
i  Is 

j  Is 

if  integer_number  -  0  then 
begin 

k  2; 

token[l]  *-  ’0* 

end 

else 

begin 

if  integer^number  <  0  then 
begin 

token (i] 
is-i+1 
end; 
j  is 

integer_number  aba  (integer_number)  ; 
while  integer_number  >  0  do 
begin 

token [i]  chr  ( (integer_nuraber  mod  10)  +  30H) ; 
intege renumber  integer_number  div  10; 

i  i  +  1 

end; 
k  i; 

i  i  -  1; 

while  j  <  i  do 
begin 

Temp_Char  token {i]j 

token(i]  :-token(j]; 
token [jl  teinp_char; 

j  j  +  1; 

i  i  -  1 

end; 

end; 

end;  {  str_integer  } 


procedure  str_real  (  x  ;  real;  var  token  :  tokentype  ) ; 


var 


base,  mantissa,  fraction  ;  real; 
i,  j,  exponent  :  longint; 


temp_token  :  token_type; 

function  x_to_the_y  (  x  :  real  ;  y  :  longint  )  :  real 

var 

i  :  longint; 
total  ;  real; 

begin 

total  1; 

for  i  :•  1  to  y  do 
total  total  *  x; 
x_to_the_y  total 
end;  {  x_to_the_y  } 

begin 

token  blank_token; 

if  x  -  0  then 
exponent  : -  0 
else 

begin 

exponent  Itrunc  (In  (abs (x) ) /ln(10) ) ; 
if  (exponent  <  1)  and  (abs(x)  <  1)  then 
exponent  exponent  -1 

end; 

if  exponent  <  1  then 
base  10 

else 

base  0.1; 

mantissa  :»  x  *  (x_to_the_y  (base,  abs (exponent) ) ) 
str_integer  (Itrunc  (mantissa),  temp_token) ; 
i  1; 

tokenCi]  temp_token(i) ; 
if  temp_token{2]  <>  *  '  then 
begin 

i:-  i  +  1; 

token [i]  terap_token [i] 
end; 

i  i  +  1; 

token (i ] 

fraction  abs (mantissa) ; 

for  j  1  to  10  do 
begin 

fraction  fraction  -  Itrunc (fraction) ; 

fraction  fraction  *  10; 

str_integer  ( Itrunc (fract ion ) ,  temp^token) ; 
token (i  +  j]  :■  temp_token [ 1 ] ; 
end; 

i  i  +  j  +  1; 
token t i ]  ’e’; 

str_JLnteger  (exponent,  temp_token) ; 
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for  j  1  to  3  do 

token [i  +  j]  j-  terap_token( j] ; 
end;  {  str_real  } 


procedure  val_integer (token  :  token_type;  var  number  :  longint; 

var  error_integer  :  longint); 

label  1; 

var  i.:  longint; 

real_number,  power  :  real; 
begin 

error_integer  0; 
i  0; 

{check  for  valid  longint) 

for  i  :■  1  to  raax_token_length  do 

begin 

if  (token (i)  <>  *  ')  and  (token (i]  <>'+')  and  (token[i]  <>  ’-’)  then 
if  ((ord (token [i])  <  48)  or  (ord (token [i] )  >  57))  then 
begin 

error_integer  9999;  {  for  error  checking  -  T.F.  } 

goto  1 
end; 

end; 

i  max_token_length; 

while  (i  >  0)  and  (token [i]  -  *  *)  do  i  i-1; 

if  (i  -  0)  then  goto  1;  {if  token  -  blank  token  ) 

real_number  ord (token {il ) -48; 

power  1; 

i  i-1; 

while  (i  >  0)  do 
begin 

if  ( (ord (token [i] )  >-  48)  and  (ord (token [i] )  <-  57))  then 
begin 

power  power  *  10.0; 

real_ number  real_nuraber  +  (wrd (token [i] ) -48)  *  power; 

end; 

if  token {i]  -  •-*  then  real_number  -real_number; 
i  i-1; 

end; 

1:  number  ltrunc <real_number) ; 

end;  {  valjinteger  } 


procedure  val  real  (token  :  token_type;  var  real_number  :  real; 

var  error_integer  :  longint); 


label  1; 


var  i,j  :  longint; 

exponent  :  longint; 


:  real; 
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sign  :  longint; 
exponent_token  ;  token_type; 

{  Discarding  leading  zero  } 

Procedure  Delete_leading_zero  (var  token  :  token_type) ; 

var  i,j  :  longint; 

begin 

i  1; 

while  i  <-*  max_token_length  do 
begin 

if  (token [ij  -  ’O’)  then 
begin 

for  j  i  to  max_token_length-l  do 

begin 

token[jI  token( j+1) ; 

end; 

token(raax_token_length3  *  * ; 

end 

else 

if  (token [i]  -  ’+’)  or  (token (il  -  »-')  then 
i  i  +  1 

else 

i  raax_token_length  +  1; 

end; 

end; 


{  This  function  converts  a  packed  array  of  character  that  represents  an  integer 
to  real  number  ) 

function  char_integer_to_real  (token  :  token__type) :  real; 
label  1; 

var  i  ;  longint; 

x, power  :  real; 
begin 

x  0; 

(check  for  valid  integer} 

for  i  1  to  raax_token_length  do 

begin 

if  (token [i]  <>  *  ’)  and  (token [i]  <>  '+*)  and  (token (i I  <>  then 

if  { (ord(token(il )  <  48)  or  (ord (token (i] )  >  57))  then 
begin 

error_integer  9999;  (  for  error  checking  -  T.F. } 

goto  1 
end; 

end; 

i  max_token_length; 

while  (i  >  0)  and  (token [i]  -  *  ’)  do  i  i-  i-1; 
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if  (i  -  0)  then  goto  1;  I  if  token  -  blank  token  } 

x  s-  ord (token (i] ) -48; 
power  1; 
i  i-1; 

while  (i  >  0)  do 
begin 

if  ( (ord (token [i] )  >-  48)  and  (ord (token [i))  <-  57))  then 
begin 

power  power*10.0; 
x  x  +  (ord (token (i]) -48) *power; 
end; 

if  tokentil  -  •-•  then  x  -x; 
i  i-1; 
end; 

1:  char_integer_to_real  s-  x; 

end;  {  of  char  integer  to  real  conversion  ) 


(  beginning  of  the  function  token  to  real  converter  ) 
begin 

exponent  0; 

error^integer  i-  0;  {  if  stays  0  then  no  error  occurred  -  T.F. 

delete_leading_zero  (token) ; 

(  Detecting  whether  digit  left  of  decimal  point  is  0  } 

if  (token [1]  -  )  or  ((token [2]  -  '.*)  and 

not  (token [1]  in  [,1,..,9,])>  then 

(  +  or  -  sign  could  have  preceded  the  decimal  point  ) 

begin 

if  tokentl]  -  *.•  then  i  2 
else  i  3; 

while  token (i]  -  *0*  do 
begin 

exponent  exponent-1; 
i  i  +  1; 
end 

end; 

{  Detecting  decimal  point  } 

i  1; 

while  (i  <-  max_token_length)  do 
begin 
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if  token [i]  -  then 
begin 

for  j  i  to  max_token_length-l  do 
token(j]  token [j+1] ; 
token [max_token_length]  '  *; 
i  jnax_token_length: 

end 

else 

if  (tokenlil  -  *e')  or  <token{i]  -  'EM  then 
i  rcax_token_length 
else 

if  (ord (token [i] )  >-  48)  and  (ord (token[i] )  <-  57)  then 
exponent  exponent* 1; 

i  i  +  1; 

end; 

{  check  for  exponential  notation  1  e*  or  ’E*  ) 

i  1; 

while  (i  <-  max_token_length)  do 
begin 

if  (token[i]  -  *e')  or  (token(i)  -  'E')  then 
begin 

token [i]  *  *; 

for  j  1  to  raax_token_length  do 
begin 

exponent^ token ( j J  *  *; 

end; 

for  j  i+1  to  max_token_length  do 
begin 

exponent_token [ j ]  ;»  tokentj]; 
token [j]  '  ' ; 

end; 

x  char_integer__to_real(exponent_token) ; 
exponent  exponent  +  round (x); 

i  max_token_length  +  1; 

end 

else 

i  i  +  1; 

end; 

x  char_integer_to_real (token) ; 
while  ab3(x)  >-  1  do  x  x/10; 

if  exponent  >  0  then 

for  i  1  to  exponent  do  x  x*10.0; 
if  exponent  <  0  then 

for  i  -1  downto  exponent  do  x  x/10.0; 
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Is  real^number  j-  x; 
end; 

procedure  vrite_token  (var  x  s  text;  token  :  token_type  ); 

var 

i  :  longint; 

begin 

i  1; 

while  (i  <-  max_token_length)  do 
begin 

if  i  -  max_token_length  then 
begin 

if  token [i]  <>  *  *  then  write (x, token [i] ) ; 
i  i+1 
end 
else 

if  ( (token fi]  -  *  ’)  and  (token [i  +1]  -  *  ’))  then 
i  max_token_length  +  1 

else 

begin 

write (x,  token{i]); 
i  i  +  1 

end 

end 

end;  {  write_token_string  ) 

procedure  read_token  (  var  token  s  token_type  ) ; 
var 

i  ;  longint; 
begin 

i  1; 

token  blank_token; 

while  (not  eoln)  and  (i  <  roax_token_length)  do 
begin 

read  (token [i]); 
i  i  +  1 
end; 
readln; 


end;  {  read_token  } . 
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File:  EXPRSION.DEF 
public  exprsion; 

procedure  insert_child__expression (operand  :  operand_type; operator  s  longint); 
procedure  insert_sibling_expression (operand  :  operand_type ; operator : longint ) ; 
procedure  reset_last__expreseion(head_operand  :  operand_type) ; 
procedure  node_di splay (expression  :  expression_pointer) ; 
procedure  create_expression(var  expression  :  expre ssion_po inter ) ; 
procedure  delete_expression(var  expression  :  expressionjpointer) ; 

procedure  fetch_expression_operand (expression  :  expressionjpointer; var  operand  :  operand_type) ; 
function  assignraent_necessary  (var  expression  :  expre 3  3ion_pointer)  -.boolean; 
function  index_assignraentjneeessary (var  expression  :  expression_pointer) :  boolean; 
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File:  EXPRSIOM.PAS 
module  exprslon; 

$ include (expr si on . def ) 

$include ( global . def) 

$include (utility . def) 

$ include ( erau_lib . def ) 

private  exprsion; 

procedure  insert_child_expression (operand  :  operand_type; operator  :  longint) 
begin 

{  last_expression  has  to  be  not  equal  to  nil  ) 
last_expression[expression_levell A.id  operand. id? 
last_expression[expression__level]  A.id_type  operand . id_type ? 

last  expression [expression_level] A. index  operand. index; 
last  expression [expression_levell  A. off set  operand. off set; 

last_expression[expression_level] A. operator  operator; 
create_expression(nev_expression) ; 

last_expression[expression_level] A. right  new_expression; 
new_expressionA.left  last_expression[expression_level] ; 
create_expression (new_expression) ; 

last_expression[expression_level] A.down  new_expression; 
nev_expressionA.up  last_expression[expression_level] ; 
last  expression [expression_level]  : —  new_expression; 
end;  (  of  insert_child_expression  ) 

procedure  insert_sibling_expression(operand  :  operand_type; operator : longint) 
begin 

{  last_expression  has  to  be  not  equal  to  nil  J 
la3t_expression[expression_level] A.id  s-  operand. id; 
last_expressiontexpression_level] A.id_type  :»  operand. id_type; 
last_expression [expression_levell A . index  operand. index; 
last^expressiontexpression^level] A. off set  operand. off set; 
last_expression[expression_level] A. operator  operator; 
create^expression <new_expression) ; 

last_expression[expression_level] A. right  new_expression; 

new_expressionA.left  last_expression[expression_level] ; 
last_expression  (expression__level]  new_expression; 

end;  {  of  right  insert  expression  ) 

procedure  reset_la3t_expression (head_operand  :  operand_type) ; 
begin 

last_expressionfexpression_level]  first_expression [expression  JLevel] ; 

expression_operator [expression_level]  null_operator; 
last_expression[expression_levell A.id  head_operand.id; 
last_expression[expression_level] A.id_type  head_operand.id_type; 
last__expression(expression_level]  A. operator  :«  null_operator; 
last_expression[expression_level]A. address [1]  7fffH; 
last_expression [expression_level] A. index  head_operand . index; 

last_expression [expression_level] A. offset  :•  head_operand. offset; 
end;  {  of  reset_last_expression  ) 
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procedure  node_display (expression  :  expression__pointer) ; 
begin 

if  expression  <>  nil  then 
with  expression*  do 
begin 

writeln (outfile, ' {  id  :  * ,id); 
writeln (outfile, '  id  type  :  ’,id_type); 

write  (outfile. '  operator  :  '); 

case  expression*. operator  of 
addition:  writeln (outf ile, '+*) ; 
division:  writeln (outfile, ' \ ’) ; 
multiplication:  writeln  (outfile,  '*'); 
unary_minus:  writeln (outfile, 'u- * ) ; 
r_minus:  writeln (outfile, 'r-* ) ; 
unary_float:  writeln (out file, 'float'); 
unary_trunc:  writeln (outfile, 'trunc' ) ; 
unary_round:  writeln (outfile, ' round* ) ; 
subtraction:  writeln (outfile, 
or_operation : writeln (outfile, ' or ' ) ; 
and__operation:  writeln  (outfile,  ’and') ; 
unary jplus: writeln (outfile, 'unary_plus' ) ; 
unary  not : writeln (outfile, *unary_not ' ) ; 
greater__than: writeln  (outfile,  *>*) ; 
less_than: writeln (outfile, *<’)  ; 
greater_than_or_equal: writeln (out file, ’>-'); 
less_than_or_equal: writeln (outfile, '<-*) ; 
not_equal: writeln (outfile, *<>*); 
equal: writeln (outfile, '-'); 
null_operator :  writeln (out file, 'null'); 
unary_index:  writeln (outfile, ’unary  jlndex’ ) ; 
otherwise  writeln (outfile, expression* .operator) ; 
end; 

writeln (outfile, ’  offset  :  ’.offset); 

writeln (outfile, ’  index  :  ’.index); 

i  It 

while  (address [i]  <>  7fffH)  do 
begin 

writeln (outfile, '  address i, ' ]  :  address ( il) ; 

i  i+1; 

if  i  >  raax_branch_pointer  then 
begin 

writeln (errorfile) ; 

writeln (errorfile, ’maximum  branch  pointer  exceeded’); 
error_found; 
end; 
end; 

if  left  <>  nil  then 

write (outfile, *  left*  :  ’, left*. id); 

if  right  <>  nil  then 

write (outfile, ’  right*  :  right* .id); 


if  up  <>  nil  then 
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write (out file, * 
if  down  <>  nil  then 
write (outfile, * 
writeln(outfile,  ’ 
end 
else 

writeln< out file, * { 

end; 


up*  :  * , up* . id) ; 

down*  ;  1 , down''. id)  ; 

)’); 

Nil  )  ’ ) ; 


procedure  create_expression(var  expression  :  expressionjpointer) ; 
begin 

new (expression) ; 
expression*.left  nil; 
expression* .right  :•  nil; 
expression* .up  s-  nil; 
expression* .down  :«■  nil; 
expression*. address (1]  :«  7fffH; 
expression* . index  ;•  blank_token; 
expression*. offset  0; 

expression*. id_type  general_symbol_type; 

expression*. id  blank_token: 

expression*. operator  null_operator; 

end; 

procedure  delete_expression(var  expression  :  expressionjpointer) ; 
begin 

if  expression*. up  <>  nil  then 
begin 

expression  expression*. up; 
dispose(expression*.down) ; 
expression*. down  nil; 
end 
else 
begin 

if  expression*. left  <>  nil  then 
begin 

expression  expression*. left; 
dispose (expression*. right) ; 
expression* . right  nil; 
end 
else 

dispose (expression) ; 

end; 

end;  {of  delete_expression  } 

function  assignment^necessary (var  expression  :  expression_pointer) : 

var  real_zero  :  token_type; 

begin 

str_real (0.0,real_zero) ; 
temp_token  blanket oken; 

add_char_to_string  (temp_token,  'O'); 


boolean; 
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with  expression*. down*. right*  do 
begin 

if  {(id  -  terap_token)  or  (id  -  real^zero) )  and 
(index  -  blank_token)  and  (offset  -  0)  then 
begin 

if  (down  -  nil)  and  (left*. down  -  nil)  then 
assignment^necessary  false 
else 

assignraent__necessary  true; 

end 

else 

assignraent_necessary  true; 

end; 

end;  {  of  assignment_necessary  } 

function  index_assignment_necessary (var  expression  :  expressionjpointer) :  boolean; 

var  terap_id  :  token_type; 

begin 

with  expression* .down*  do 
begin 

(swap  the  constant  to  the  second  operand  if  the  first  operand  is  a  constant) 

(  node_display (right) ;  ) 
if  (index  -  blank_token)  and 

(  ( right *.id_type  -  integer_constant__symbol__type)  or 

(right*. id  -  *0  ')  )  then 

begin 

if  (down  -  nil)  and  (right*. down  -  nil)  then 

if  (right*. operator  -  addition)  or  (right*. operator  -  subtraction)  then 
index_assignment_necessary  false 

else 

index_assigninent_necessary  true 

else 

index_assignment_necessary  true; 

end 

else 

index_assignment_necessary  true; 

end; 

end;  (  of  index_assignraent_necessary  } 

procedure  fetch_expression_operand(expression  :  expressionjpointer; var  operand  ;  operand_type) ; 
begin 

operand. id  expression* .id; 
operand.id_type  expression* .id_type; 
operand . index  expression* .index; 
operand. offset  expression* .off set; 

end;  {  fetch_expression_operand  } . 
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File:  BXPRTREE.DEF 
public  exprtree; 

Procedure  generate_arithmetic_assignraent (var  expression  :  expression_pointer) ; 
Procedure  generate_real__conversion(var  operand : token_type )  ; 

Procedure  check_operands_type  (var  expression  :  expression_pointer) ; 

Procedure  check_result_type(var  expression  :  expression_pointer) ; 

Procedure  correct_type(var  expression  :  expression_pointer) ; 

Procedure  type_checking (var  expression  :  expression_pointer) ; 

Procedure  create_arithmetic_term(var  expression  :  expression_pointer) ; 
Procedure  generate_arithraetic_term(var  expression  :  expression_pointer) ; 
Procedure  delete_term(var  expression  :  expressionjpointer) ; 

Procedure  delete_redundant_term(var  expression  :  expression_pointer) ; 
Procedure  transform(var  expression  :  expression_pointer) ; 

Procedure  transform_right; 

Procedure  transforra_down: 

Procedure  traverse_down; 

Procedure  traverse_right; 

Procedure  traverse_expression_tree; 

Procedure  Trans forra_expression_tree; 

Procedure  Evaluate_expression_tree; 
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File:  EXPRTREE . PAS 
module  exprtree; 

$ include  (  exprtree . def) 

$include (global . def) 

$include (code_gen . def) 

^include (exprsion . def) 

$ include (utility. def) 

$include (emu_lib. def ) 
private  exprtree: 

Procedure  generate_-arithmetic_assignment (var  expression  :  expression_pointer) ; 
label  1; 

var  F,R,S  :  operand^type; 

opcode, expression^type  :  longint; 
begin 

type_checlcing  (expression) ; 

if  debug  then 

begin 

writeln( out file, * - Generate_arithraetic_assignment - ' ); 

node__display  (expression* . left'*  .up)  ; 
node_di3play (expression* .left) ; 
node_display (expression) ; 
end; 

if  expression*. operator  -  unary_index  then 
begin 

expression*.left*.up*.index  expression* .left* .id; 
goto  1  (exit); 
end; 

opcode  expression* .operator; 
express ion_type  expression* . left* .up* . id_type; 
case  expression_type  of 
real_symbol_type  : 
begin 

if  (opcode-multiplication)  or 
(opcode-addition)  or 
(opcode-subtraction)  or 
(opcode-unary_float)  or 
(opcode-unary_plus)  or 
(opcode-unary_minus)  or 
(opcode-null_operator)  then 
begin 

fetch_expression (F, R, S, expression) ; 
generate_ALU_operation (F, R, S, opcode) ; 
end 
else 
begin 

writeln (errorfile) ; 

writeln(errorfile, ’operator  mismatch') ; 
error__found; 
end; 


end; 


boolean_symbol_type  : 

begin 

case  opcode  of 

greater_than  :  generate_greater_than (expression) ; 
less_than  :  generate_less_than (expression) ; 
equal  :  generate__equal  (expression) ; 
not_equal  :  generate__not_equal  (expression)  ; 

greater_than_or_equal  :  generate_greater_than_or_equal (expression) ; 

less  than  or_equal  s  genera te_less_than_or_equal (expression) ; 

unary_not  :  generate_unary_not (expression) ; 

and  operation  :  generate_and (expression) ; 

or_operation  :  generate_or (expression) ; 

addition  :  begin 

f e t  ch_expr es  s ion ( F , R , S , expr e  s  s ion ) ; 
if  (f.idd]-’*')  then  generate_or  (expression) 

else  generate_ALU_operation (F, R, S, opcode) 

end; 

multiplication  s 
begin 

fetch_expression(F, R, S, expression) ; 

if  < f. id d ]-'#*>  then  generate_or (expression) 

else  generate_ALU_operation(F,R, S,  opcode) 

end; 

otherwise  write_error <* unknown  boolean  operation 

end; 

end; 

integer_symbol_type  : 
begin 

if  (opcode-multiplication)  or 
(opcode-addition)  or 
(opcode-subtraction)  or 
(opcode-unary_trunc)  or 
(opcode-unary_round)  or 
(opcode-unary__plus)  or 
(opcode-unary_rainus)  or 
(opcode-null_operator)  then 
begin 

fetch_expression (F,R, S, expression) ; 
generate_ALU_operation (F, R, S, opcode) ; 
end 
else 
begin 

writeln{ error file) ; 

writeln(errorfile, 'operator  mismatch' ); 
error_found; 
end; 
end; 

otherwise 

begin 
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writeln (error file) ; 

writeln (error file, ’unknown  expression^type  -  • ,  expression__type) ; 
error_found; 
end; 

end;  {  of  case  expression_type  of  > 

1:  end;  {  of  generate  arithmetic  assignment  } 

Procedure  generate_real_conversion(var  operand: token_type) ; 
begin 

{  expression_operator texpression_level]  unary_float; 
if  operand [1]  —  '%'  then 
begin 

assign_terap_variable {operand) ; 
end; 

R_operand  operand; 

str_integer (next_terap_variable_ location, operand) ; 
temp 

F_result  s -  concat ( ’ *  * , operand) ; 
operand  F_result; 

S_operand  blank_token; 

S_operandIl]  ’O’; 
express ion_type  real^syrabo^type; 

genera te_arithraetic_microcode;  ) 
end;  (  of  generate__real_conversion  ) 

Procedure  check_operands_type (var  expression  :  expression__pointer) ; 

var  real__zero  :  token_type; 

begin 

{  check  to  avoid  real  conversion  when  operand  -  0  ) 

temp_token  blank_token; 

if  ( expression* . id ( 1 ]  -  ’O’)  and 

( (expression *. left *.id_type  -  real_symbol_type)  or 
(expression*. left*. id_type  -  real_constant_symbol_type) )  then 
begin 

str_real<0.0,real_zero) ; 
expression* . id  real_zero; 

expression*. id_type  real_constant_ symbol_jtype; 

end 
else 

if  (expression*. left*. id [1]  -  ’O’)  and 

( (expression*. id_type  -  real_symbol_type)  or 
(expression*. id^type  -  real_constant_symbol_type) )  then 
begin 

str_real(0.0,real_zero) ; 
expression*. left*. id  real_zero; 

expression*. left*. id_type  real_constant_symbol_type; 
end;  {  of  check  to  avoid  real  conversion  when  operand  -  0  ) 

if  (expression* . operator-unary_minus)  or 
(expression* . operator-unary_trunc)  or 
(expression* . opera tor-unary_round)  or 
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(expression* . operator-unary_not )  then 
begin 

(  acceptable  } 
end 
else 

if  (expression* .operator-unary_index)  then 
begin 

if  (expression*. left*. id_type  -  integer_symbol_type)  or 

(expression* . left* . id_type  -  integer_constant_symbol_type)  then 
begin 

{  acceptable  } 
end 

else 

begin 

vriteln (errorfile) ; 

writeln (errorfile, ’Error  I!!  Operands  type  mismatch'); 

error_found; 

end; 

end 

else 

if  expression*. id_type  <>  expression*. left*. id_type  then 
begin 

if  ( (expression*. id__type  -  integer_symbol_type)  or 

( expression*. id_type  -  integer_constant_symbol_type) )  and 
( (expression*. left*. id_type  -  real_symbol_type)  or 
(expression*. left*. id_type  -  real_constant_symbol_type) )  then 
begin 

generate_real_conversion (expression* . id) ; 

expression* .id^type  :«  real_symbol_type; 
end 
else 

if  ( (expression*. id_type  -  real_syrabol_type)  or 

( expression*. id_type  ~  real_constant_3ymbol_type) )  and 
( (expression*. left*. id_type  -  integer_syrabol_type)  or 
(expression*.left*.id_type  -  integer_constant_symbol_type) )  then 
begin 

generate_real_conversion (expression* . left* . id) ; 

expression*.left*.id_type  real_symbol_type; 
end 
else 

if  ( (expression* . id_type  -  real_syrabol_type)  or 

( expression*. id^type  -  real__constant_symbol_type) )  and 
(( expression*. le ft*. id_type  -  real_symbol_type)  or 
(expression*. left*. id__type  -  real_constant_symbol_type) )  then 
begin 

(  acceptable  combination  ) 
end 
else 

if  ( (expression*. id_type  -  integer_symbol_type)  or 

(expression* .  id_type  -  integer__constant_symbol_type) )  and 
( (expression* .left*. id_type  -  integer_symbol_type)  or 
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(expression*. left *.id_type  -  integer_constant_symbol_type) )  then 
begin 

(  acceptable  combination  } 
end 

else 

if  (( expression*. id_type  -  boolean_constant_symbol_type)  or 
(expression*. id_type  -  boolean_syrabol_type) )  and 
( (expression*. left*. id_type  -  boolean_constant_symbol_type)  or 
(expression*. left*. id_type  -  boolean_symbol_type) )  and 
( (expression*. operator  -  and_operation)  or 
(expression*. operator  -  or_operation)  or 
(expression*. operator  -  equal)  or 
(expression*. operator-*  unary_not)  or 
(expression*. operator  -  addition))  then 
begin 

(  acceptable  combination  ) 
end 
else 
begin 

writeln(errorfile)  ; 

writeln(errorfile, ’Error  !!!  Operands  type  mismatch'); 
error_found; 
end; 
end; 

end;  (of  check_operands_type  ) 

Procedure  checJc_result_type  (var  expression  :  expression_pointer)  ; 
begin 

with  expression*  do 
begin 

if  (operator-unary_trunc)  or 
(operator-unary_round)  then 
begin 

if  (left* .up* .id (1J  -  •%*)  or  (left*. up*. id (11  -  '*')  or 
(left*. up*. id (1]  -  '  t')  then 
left* . up* . id_type  integer_symbol_type ; 
if  (left*  .up* . id^type  -  integer__symbol_type)  and 
( (left*.id_type  -  real_symbol_type)  or 

(left*.id_type  -  real_constant_symbol_type) )  then 

begin 

{  acceptable  } 
end 
else 
begin 

writeln (errorfile) ; 

writeln (errorfile, 'Error  !!!  type  mismatch  ;  '); 
error_found; 
end; 

end  {  of  operator  -  unary_trunc  . .  } 
else 

if  (left* .up* . id (1)  -  ’%')  or 
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Ueft*.up*.idfl]  -  *#f)  or 
(left* .up-1 . id [11  -  *4’)  then 
begin 

if  (operator-greater_than)  or 
(operator-less_than)  or 
(operator-equal)  or 
(operator-not_equal)  or 
(oper ator-les  s_than_or_equal )  or 
(operator-unary_not)  or 
(operator-greater_than_or_equal)  then 
begin 

left*. up* . id_type  boolean_symbol__type; 
express ion_type  boolean_symbol_type; 
end 
else 
begin 

left* .up* . id_type  expression_type; 
end; 

end  (  of  temporary  variable  '%*  and  } 

else 

begin 

if  (operator-  unary_index)  then 
begin 

{  acceptable  combination  ) 
end 
else 

if  (left* .up* . id_type  -  real_symbol_type)  and 
( (left* . id_type  -  real_syrabol_type)  or 
( left* . id_type  -  real_constant_symbol_type)  or 
(left* . id_type  -  integer_symbol_type )  or 
(left* .id_type  -  integer_constant_symbol__type) )  then 
begin 

{  acceptable  combination  } 
end 
else 

if  ( left* . up* . id_type  -  integer_symbol_type)  and 
( (left*.id_type  -  integer_symbol_type)  or 
( left* . id_type  -  integer_constant_symbol_type) )  then 
begin 

(  acceptable  combination  ) 
end 
else 

if  (left* .up* .id_type  -  boolean_symbol_type)  then 
begin 

if  { (left*.id_type  -  real_symbol_type)  or 

(left* . id_type  -  real_constant_symbol_type)  or 
(left*.id_type  -  integer_symbol_type)  or 
(left* . id_type  -  integer_constant_symbol_type) )  and 
( (operator-greater_than)  or 
(operator-less_than)  or 
(operator-equal)  or 
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(operator-not_equal)  or 
(operator-less_than_or__equal)  or 
(operator-greater_than_or__equal) )  then 
begin 

expression_type  boolean_symbol_type; 

end 

else 

if  ( (left*.id_type  -  boolean_constant_symbol_type)  or 
(left*.id_type  -  boolean_symbol_type) )  and 
( (operator-  and_operation)  or 
(operator-  or_operation)  or 
(operator-  unary_not)  or 
(operator-  addition) )  then 

begin 

(  acceptable  ) 

end 

else 

begin 

writeln (errorfile) ; 

writeln (errorfile, 'Error  ! J !  type  mismatch' ) ; 
error_found; 
end; 

end 

else 

begin 

writeln (errorfile) ; 

writeln (errorfile, 'Error  !!!  type  mismatch'); 
error_found; 
end; 

end;  (  third  case  ) 
end;  (  of  with  expression*  ) 
end;  {  of  check_result_type  ) 

Procedure  correct_type (var  expression  :  express ionjpointer) ; 
begin 

with  expression*  do 
begin 

if  id_type  -  real_array_symbol_type  then 
id_type  real_symbol_type 

else 

if  id_type  -  integer_array_symbol_type  then 
id_type  integer_syrabol_type 

else 

if  id_type  -  boolean_array_symbol_type  then 
id_type  s-  boolean_symbol_type; 

end; 

with  expression* .left*  do 
begin 

if  id_type  -  real_array_symbol_type  then 
id_type  t-  real_symbol_type 


else 
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if  id_type  -  integer_array_syrabol_type  then 
id_type  integer_symbol_type 

else 

if  id_type  -  boolean_array_symbol_type  then 
id_type  boolean_symbol_type; 

end; 

with  expression''. left* .up*  do 
begin 

if  id__type  -  real_array_symbol_type  then 
id_type  real_symbol_type 

else 

if  id_type  -  integer_array_syrcbol_type  then 
id_type  integer_symbol_type 

else 

if  id_type  -  boolean_array_syrabol__type  then 
id_type  boolean_symbol_type; 

end; 

end;  {  of  correct_type  ) 

Procedure  type_checking(var  expression  ;  expression_pointer) ; 
begin 

correct_type {expression) ; 

if  (expression* .left*. up* .id [1]  <>  *♦')  and 

<expression*.left*.up*.id(l]  <>  *%’)  and 

(expression*.left*.up*.id[l]  <>  '4*)  then 

begin 

expression_type  expression* .left* .up* ,id_type; 
end 
else 

if  (expression*.id_type  -  real_symbol_type)  or 

(expression*.id_type  -  real_constant_syrabol_type)  or 
(expression*. left *.id_type  -  real_symbol_type)  or 
(expression* . left* .id^type  -  real_constant_symbol_type)  then 
begin 

expression_type  realms ymbol_type; 

end 
else 

if  (expression* . left* . id_type-boolean_syrabol_type)  or 

(expression*  .  left*  .  id_type*boolean_constant_symbol__type)  then 
begin 

expression^  ype  boolean_symbol_type; 

end 
else 
begin 

expression_type  integer_symbol_type; 

end; 

checJc_operands_type  (expression) ; 
chec)c_result_type  (expression) ; 
end;  {  of  type_checking  } 


function  precedence (operator  ;  longint) rlongint; 
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begin 

case  operator  of 

null_operator  :  precedence  s-  0; 
great er_than  :  precedence  s-  1; 
greater_than_or_equal  :  precedence  1; 
less_than  :  precedence  1; 
less_than_or_equal  s  precedence  :«  1; 


equal 

precedence  s-  1; 

not_equal 

precedence  1; 

unary _not 

precedence  7; 

and_operation 

precedence  j-  6; 

or_operation 

precedence  3; 

addition 

precedence  3; 

subtraction 

precedence  :•  3; 

rjitinus 

precedence  3; 

division 

precedence  ;•  5; 

multiplication 

precedence  :«■  6; 

unaryjninus 

precedence  7; 

unary_round 

precedence  s -  7 ; 

unary_trunc 

precedence  7; 

unary_float 

precedence  7; 

unary_index 

precedence  7; 

end; 

end;  {  of  precedence  ) 

Procedure  create_arithrcetic_terra(var  expression  :  expression_pointer) ; 
var  temp_expression  :  expression_pointer; 

token  :  token_type; 
begin 

create_expression (new_expression) ; 
assign_percent_variable (token) ; 
new_expression''.id  token; 
new_expressionA.id_type  symbol^type; 
new__expressionA.  opera  tor  expression'',  operator; 
expression''. operator  null__operator; 
if  expression ''.up  <>  nil  then 
begin 

new_expression's , up  expression^-up; 
expression''. up  new_expression; 
new_expression~.down  expression; 
expression  new_expression* . up; 
expression*' .down  new_expres3ion; 
end 
else 

if  expression'*. left  <>  nil  then 
begin 

new_expre3sion'* .down  expression; 
expression'*  .up  new_expression; 
new_expre3sion''.left  expression* . left; 
expression-* .left  :»  nil; 
expression  new_expression* . left; 
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expression* . right  new_expression; 
end; 

expression  nev^expression* .down? 

if  expression*. right*. right  <>  nil  then 
begin 

expression  expression*. right? 

expression  expression*. right; 

expression* .left  : -  new_expression; 
new__expres sion*. right  expression; 
expression  new_expression*.down; 
expression  expression* . right? 

expression* . right  nil; 
end; 

expression  new_expression; 
end;  {  of  create_arithmetic__term  ) 

Procedure  generate_arithmetic_term(var  expression  :  expression_pointer) 
begin 

if  (  precedence (expression*. right*. operator)  >- 

precedence (expression* .right* .right* .operator)  )  then 
create_arithraetic_terra( expression) 

else 

if  (  expression* .right* .right* .right  )  <>  nil  then 
generate_arithmetic_tenn  (expression* . right) 
else 

create_arithraetic_term (expression*. right) ; 
end;  {  of  generate_arithmetic_term  } 

Procedure  delete_term(var  expression  :  expressionjpointer) ; 
begin 

if  expression*. down*. down  -  nil  then 
begin 

dispose (expression* . down) ; 
expression*. down  nil; 
end 
else 
begin 

new_expression  expression*. down; 

new_expression  new_expression* .down; 

new_expression*.up  expression; 
new_expression  expression* . down? 

expression*. down  new_expression* .down; 
dispose (new_expression) ; 
end; 

end?  {  of  delete_term  ) 

Procedure  delete_redundant_term(var  expression  :  expressionjpointer) ; 
begin 

if  (expression* .down  <>  nil)  then 
if  (expression*. down*. left  -  nil)  then 
if  (expression* .down* .right-nil)  then 


Digital  Emulation  Technology  Laboratory  Final  Report 


if  (expression*. down*. operator-null_operator)  then 
begin 

if  (expression*. down*. id [1]-*%*)  then 
begin 

delete_tem»( expression) ; 
delete_redundant_term ( expression) ; 
end 
else 

if  (expression*. id (1 1 -*%’ )  then 
begin 

expression*. id  expression*. down* . id; 

expression*. id_type  expression*. down* .id_type; 

expression*. index  expression* .down* .index; 

expression*. off set  expression* . down* .offset; 

de let e_term (expression) ; 
delete^redundant^terrM expression)  ; 
end; 
end 
else 

if  (expression*. operator  -  null_operator)  and 
(expression*. right  -  nil)  and 
(expression*. id [1]  -  f%’)  then 
begin 

expression*.id  expression*. down*. id; 
expression*.id_type  expression*. down*. id_type; 
expression*. operator  expression*. down*. operator; 

delete^term (expression) ; 
delete_redundant_t erm ( expression ) ; 
end 
else 

if  (expression*. down*. down  <>  nil)  then 
begin 

delete__redundant_t erm  ( expression* .  down )  ; 
if  (expression* .down* .down  <>  nil)  then 
begin 

if  (expression*. down*. operator  -  unary_not)  and 

(expression*. down*. down*. operator  -  unary_not)  then 
begin 

delete_term (expression) ; 

expression*.down* .operator  j-  null_operator; 
if  expression*. down*. id (1]  -  •%*  then 
delete_term (expression) ; 
delete_redundant_term (expression) ; 
end 
else 

if  (expression*. down*. operator  -  unary_minus)  and 

(expression*. down*  .down*. operator  -  unary__minus)  then 
begin 

delete_term (expression) ; 

expression*. down*. operator  null_operator; 

if  expression*. down*. id (1]  -  '%’  then 
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delete_term( expression) ; 
delete_redundant_term (expression) ; 
end; 
end; 
end; 

end;  (  of  delete_redundant_term  ) 

Procedure  transformer  expression  :  expression_pointer) ; 

var  terap_token  !  token_type; 

begin 

if ( (expression*. operator  -  unary_minus)  or 
(expression* .operator  -  unary_round)  or 
(expression* .operator  -  unary_not)  or 
(expression*. operator  -  unary_trunc)  or 
(expression* .operator  —  unary_ index) )  and 
(expression* .id  <>  blank_token)  then 

begin 

cr eat e_expres sion (new_expr ess ion) ; 
new^expression* .id  blank_token; 
new  expression* .operator  ;■  expression* . operator; 
expression* .operator  :■  nuil_operator; 
new_expression*.left  expression; 
expression* . right  new_expression; 
end 
else 

if  (expression*. id (1]  <>  '%’)  and 

(expression*. id  <>  blank_token  )  and 
(expression* .left  -  nil)  and 
(expression*. right  -  nil)  then 
begin 

create__expression  (new_expression) ; 
new_expression* . id_ type  expression* .id_type: 

new_expression*.id  :*  blank_token; 
new_expression* . id (11  :•  'O’; 
new__expre ss ion* .operator  addition; 
expression* .operator  :*  null_operator; 
new_expression*.left  :•  expression; 
expression* . right  s—  new_expression; 
end; 

if  (expression* . right  <>  nil)  then 

while  (expression*. right*. right  <>  nil)  do 
generate_arithmetic_terra (expression) ; 
end;  {  of  transform  } 

Procedure  transform_down; 
var  temp_var  :  integer; 
begin 

current_expression  current_expression*.down; 
delete_redundant_term(current_expression)  ; 
trans form (current_expres sion) ; 

if  current_expres sion* .down  <>  nil  then  trans form_down; 
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if  current_expressionA. right  <>  nil  then  transform_right 
if  ( cur rent_expressionA. index  <>  blank_token)  then 

terap_var  assign_index (current_expressionA . index) ; 
eurrent_expression  current_expressionA .up? 
end?  (  of  transform  down  } 

procedure  transforra_right? 
var  teinp_var  j  integer? 
begin 

current_expression  current_expressionA .right? 
delete_redundant_term (current_expression) ? 
transform (current^expression) ? 

if  current_expressionA.down  <>  nil  then  transforra_down? 
if  cur rent_expr ess ion A, right  <>  nil  then  trans former ight 
if  < cur rent_expr ess ion A. index  <>  blank_token)  then 

temp^var  assign_index (current_expressionA .index) ; 
current_expression  cur rent_expressionA. left? 

end?  {  of  transforra_right  } 

Procedure  traverae^down? 
begin 

current_expression  current_expressionA.down? 

if  cur rent_expressionA. down  <>  nil  then  traverse_down? 
if  cur rent_expressionA. right  <>  nil  then  traverse_right; 
{  node_display (current_expression) ;  ) 
current_expression  current_expressionA .up? 

dispose (current_expressionA . down) ? 
current_expressionA .down  nil? 
end?  {  of  traverse_down  } 

Procedure  traverse_right? 
begin 

cur rent_expression  : -  curr ent_expre s  sionA . right  ? 
if  current_expressionA .down  <>  nil  then  traverse_down? 
if  current_expressionA. right  <>  nil  then  traverse_right? 
{  node_display (current_expresaion) ?  } 
generate_arithmetic_assignraent (current_expression) ? 
current_expression  current_expressionA.left? 
dispose (current_expressionA . right) ? 
current_expressionA .right  nil? 
end?  {  of  traverse_right  ) 

Procedure  traverse_expression_tree? 
var  head_id  ;  token_type; 

temp_var  :  integer? 
begin 

current_expression  s-  first_expression [expression_level] 
head_id  current_expressionA .id? 
delete_redundant_term ( curr ent_expr e  s  si on ) ? 
begin 

if  (current_expre3sionA. index  <>  blank_token)  then 
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temp_var  assign_index (current_expressionA . index) ; 
trans  f orm_down ; 
t raver s e_down ; 
end; 

end;  {  of  traverseexpressiontree  } 

Procedure  Tran s  f orm_expr e  s  sion_tr ee ; 
var  head_id  :  token_type; 

temp_var  :  integer; 
begin 

current_expression  first__expre93ion[expression_level] ; 
head_id  current_expressionA.id; 

delet e_redundant _terra { current_expre3sion) ; 
if  (eurrent_expression'%.  index  <>  blank_token)  then 

temp_var  aasign^ndextcurren^expression* .index)  ; 
transform_down; 

end;  {  of  trans form_expre3sion_tree  ) 

Procedure  Evaluate_expression_tree; 

var  head_id  :  token_type; 

begin 

current_expression  :■*  fir3t_expre»sion{expre3sion_level] ; 

head_id  current_expression^ . id; 

traverse_down; 

end;  {  of  Evaluate_expression_tree  ) . 
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File:  FETCH_TK . DBF 
public  fetch_tk; 

procedure  fetch_token; 
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File:  FETCHJTK.PAS 
module  fetch_tk; 

public  fetch_tk; 

procedure  fetch_token; 

$ include  ( global. def) 

$include  (utility. def) 

$ include  (erau_lib.def) 
private  fetch_tk; 

procedure  fetch_token; 

label  1; 

var 

i  :  longint; 

procedure  get_char  (var  ch  :  char); 
begin 

ch  infile*; 
get  (infile) ; 

if  (ord (ch)  >-  65)  and  (ord(ch)  <-  90)  then  ch  char (ord (ch) +20H) ; 

if  ord(ch)  -  10  then 

begin 

gotoxy (5, 24) ; 
write (line_number) ; 
line^number  line_number+l; 
end; 
end; 

procedure  unexpected_eof ; 
begin  . 

write_error ( 'unexpected  end  of  file  * , token) ; 

end; 

procedure  filter_out_blank; 
begin 

while  (  (ord (ch)  <-  20H)  or  (ord(ch)  >  7eH)  )  and  (  not  eof (infile)  )  do 
begin 

get_char  (ch) ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 
if  ch  in  upper_letter_set  then  ch  char (ord (ch) +20H) ; 
end; 
end; 

procedure  f ilt er_out_comment ; 
begin 

{  filter  out  comments  } 
if  not  eof (infile)  then 
repeat 

get_char (ch) ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 
if  ch  -  ' ( ’  then  filter_out_comment; 
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until  (ch  -  •)*)  or  (eof (infile) ) ; 
if  eof (infile)  and  (ch<>  *)*)  then 
begin 

token  s-  blank_token;  token[l]  s-  ch;  {  so  ch  can  be  passed  as 
write_error( 'closed  comment  >  expected 
end; 

if  not  eof (infile)  then 
begin 

get_char (ch) j 

if  not  eof (infile)  then  write (errorfile, ch) ; 
end; 

end;  (  of  filter  out  comment  } 

procedure  integerjnuraber; 
begin 

add_char_to_string  (token,  ch) ; 
if  ch  in  t  *  0 ' . . *  9  * ]  then 
begin 

if  not  eof (infile)  then 
begin 

get_char (ch) ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 
end; 

while  (ch  in  [,0*..*9*])  and  (not  eof (infile))  do 
begin 

add_char_to_*tring  (token,  ch) ; 
get_char (ch) ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 
end; 
end 
else 
begin 

write_error (* numeric  character  expected 
end; 
end; 

procedure  exponent; 
begin 

add_char_to_string  (token,  ch) ; 
if  not  eof (infile)  then 
begin 

get_char (ch) ; ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 

if  ((ch  -  •+»)  or  (ch-*-*))  and  (not  eof (infile))  then 

begin 

add_char_to_string  (token,  ch) ; 
get_char (ch) ; ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 
integerjnumber; 
end 


a  token  ) 
* , token) ; 


f , token) ; 


else 
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integer_nuraber; 

end 

else 

begin 

token  blank_token;  token [1]  ch;  {  so  ch  can  be  passed 
write_ error ( 'unexpected  end  of  file 
end; 

end;  {  of  procedure  exponent  ) 

Procedure  number; 
begin 

symbol_type  real_constant_symbol__type; 
add_char_to_string  (token,  ch) ; 
if  not  eof (infile)  then 
begin 

get_char (ch) ; ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 
if  ch  in  1*0* . . *9')  then  integer_number; 
if  ch  -  ' . ’  then 
begin 

if  not  eof (infile)  then 
begin 

get_char (ch) ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 

if  ch  <>  1 . *  then 

begin 

add_char_to_string  (token,  * . f ) ; 
if  not  eof (infile)  then  write (errorfile, ch) ; 
if  ch  in  [ *  0  * , . *  9  *  1  then  integer_number; 
if  ch  -  *e'  then  exponent; 
end 
else 

symbol_type  integer_constant_syrabol_type: 
end;  (  of  if  not  eof  ) 
end 
else 

if  ch  -  'e*  then 
exponent 
else 

symbol_type  integer_constant_symbol_type; 

end 

end;  (  of  number  ) 

(  expect  ch  :  char  solely  to  be  used  by  procedure  fetch  token  } 

begin 

symbol_type  genera l_symbol_type; 
token  blank_token; 
if  eof (infile)  then 
begin 

add_char_to_string  (token,  ch) ; 


a  token  } 
' , token) ; 
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goto  1 
end; 

filter_out_blank; 
if  ch-M’  then 
begin 
repeat 

f ilter_out_comment ; 
filter_out_blank; 
until  (ch  <>  MM  or  eof (infile); 
end; 

if  (eh  in  then  number 

else 

if  (  (ch  in  delimiter)  or  (ord(ch)  <  20H)  or  (ord(ch)  >  7eH)  ) 
and  (  not  eof (infile)  )  then 
begin 

add_char_to_ string  (token,  ch); 

if  ch  -  •<•  then 

begin 

get^char (ch) ; 

if  ch  in  then 

begin 

add_char_to_string  (token,  ch); 
get_ehar (ch) ; 
end; 
end 
else 

if  ch  -  *>?  then 
begin 

get_ehar (ch) ; 
if  ch  -  then 
begin 

add_char_to_string  (token,  ch) ; 
get_ehar (ch) ; 
end; 
end 
else 

get_char (ch) ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 
end 
else 
begin 

add_char_to_string  (token,  ch) ; 
if  not  eof (infile)  then 
repeat 

get— char (ch) ; 

if  not  eof (infile)  then  write (errorfile, ch) ; 
if  not  (  (ch  in  delimiter)  or  (ord(ch)  <  20H) 
or  (ord(ch)  >  7eH)  )  then 
add_char_to_string  (token,  ch) ; 
until  (ch  in  delimiter)  or  (ord(ch)  <  20H) 
or  (ord(ch)  >  7eH)  or  eof (infile); 


end; 

if  syrabol_type  -  real^constan^symbol^type  then 
begin 

val_real  (token,  real_constant_value, i)  ; 
strjreal  (real_constant_value, token) ; 
if  i  <>  0  then 
begin 

write_error ( *  real  conversion  error  ' , token) 

end; 
end 
else 

if  symbol_type  -  integer_constant_symbol_type  then 
begin 

val  integer  (token, integer_constant_value, i) ; 
str_integer  (integer__constant^value,  token) ; 
if  i  <>  0  then 
begin 

write_error ( ’real  conversion  error  • , token) 

end 
end; 


1:  end;  (  of  fetch_token  }. 
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Files  FOR_STAT.PAS 

procedure  for_loop ( for_index, upper : operand_type) ; 
var  begin_loop_address  :  longint; 
temp__operand  :  operand_type; 
one  s  operand_type; 
begin 

clear jpipeline_stage ; 

{  check  for  exit  condition  } 

assign_stack_operand (temp_operand, integer_symbol_type) ; 

free_3tack_operand? 

temp_operand. offset  0; 

terap_operand. index  blank_token; 

branch_lookahead_buffer [2]  if_negative; 

begin_loop_address  program_counter; 

generate_ALU_operation(temp_operand, upper, for_index, subtraction) ; 
corapound_s t at eraent ; 

(  increment  for_index  } 
one. id  :*>  blank_token; 
one . id [ 1 ]  *1»; 

one.id_type  int eger_const ant_symbo l_type ; 

one. off set  0; 

one. index  blank_token; 

generate_ALU_operation ( for_index, for_index, one, addition) ; 
if  (write_lookahead_buffer [1] .id  <>  blank_token)  then  generate__nop; 
writeln (outfile, * ; ' , prograrajsounter, * :  goto  ’ , begin_loop_address) ; 
microcode_address  :«•  program_counter; 
branch_address  :»  begin_loop_address; 

AM2910_opcode  :•  CJP; 
branch_opcode  unconditional; 
output_microcode_field; 
program_counter  program_counter  +  1; 

writeln (outfile, 'b  • ,begin_loop_address+2, '  ' , program_counter) ; 
end;  {  of  for_loop  ) 

procedure  for_statement; 

var  for_index, upper  ;  operand_type; 

begin_loop_address, lower_offset,  upper_offset ;  longint; 
temp__token  :  token_type; 
i  :  longint; 

initial_index_register  s  array {0 . ,max_index_register]  of  token_type; 
begin 

{  writeln (outfile, *; -  expression  express ion_number, •  - ');  ) 

expression_number  expression_number  +  1; 

fetch_token; 

find_syrabol  (token,  symbol_type,  symbol_value,  found)  ; 
if  symbol_type  <>  integer_symbol__type  then 
begin 

write_error ( *  integer  expected  * , token) ; 

end; 

for_index.id  token; 

for_ index. id_type  integer_symbol_type; 
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for_index.offset  0; 
for_index . index  blank_token; 
fetch_token; 

verify_token (token, colon) ; 
fetch_token; 

verify^token (token,  equal__token)  ; 
fetch_assigned_parameter (for_index) ; 
verif y_token (token, to_token) ; 
upper . id_type  integer_symbol_type; 
fetch_pararaeter  (upper) ; 

{  begin  of  the  for-loop  ) 

for  i  j-  0  to  ma x_index_r egi s  t  e  r  do 

begin 

initial_index_register [i)  index^register [ij ; 
end; 

f or_loop ( f or_index, upper ) ; 

(restore  the  index  register  to  its  initial  state) 

for  i  0  to  max_index_register  do 

begin 

if  initial_index_register [i]  <>  index_register (i]  then 
begin 

if  initial_index_register(i]  <>  blank_token  then 
load_index_register (initial_index_register [il ) ; 
index_register (i)  initial_index_register [ij ; 
end; 
end; 

end;  (  of  for_stateraent  } 


File:  GLOBAL. DBF 
public  global; 
const 

pi  -  3. 141592654; 
prime  -  19; 

max_token_length  -  50; 
dataram_address__limit  -  2047; 
prograra_eounter_limit  -  4095; 

temp_variable_lirait  -  100;  {  used  to  store  temporary  variables  } 

max_branch_pointer  -  20; 

raax_index_register  -  15; 

max_procedure_level  -  6; 

max_reference_pararaeter  -  15; 

max_expression_level  -10; 

max_local_variable  -  100; 

version  -  ’Computer  Architecture  Lab  Pascal  Compiler  ~  2.0 


program_heading 

- 

’program 

procedure__heading- 

* procedure 

function_heading 

- 

*  function 

blanket o ken 

- 

t 

semicolon 

- 

open_parenthesis 

- 

*  ( 

dosejparenthesis- 

*) 

comma 

- 

* 

colon 

- 

»: 

greater_than_or_equa l_token 

- 

’>- 

less_than_or_equa 1_ 

token 

- 

’<- 

greater_than_token 

- 

♦> 

less_than_token 

- 

’< 

not_equal_token 

- 

’  <> 

equal_token 

- 

not_token 

- 

'not 

and_token 

- 

'and 

or_token 

- 

'or 

raultiply_token 

- 

« * 

divide_token 

- 

’/ 

add_token 

- 

’  + 

plus_token 

- 

'  + 

percent_token 

- 

’% 

rainus_token 

- 

period 

- 

open_bracket 

- 

M 

close_bracket 

- 

M 

var_declaration 

- 

’  var 

const_declaration- 

'const 

type_declaration 

- 

'type 

begin_token 

- 

'begin 

do  token 

- 

'do 

I 

« 

1 

i 

i 

i 

i 

i 

l 

i 

i 

i 

v 

i 

t 

i 

i 
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to_token 

-  'to 

5 

foretoken 

-  'for 

' ; 

end_token 

-  'end 

’ ; 

if_token 

-  'if 

then_token 

-  'then 

else_token 

-  'else 

while_token 

-  'while 

' ; 

repeat_token 

-  'repeat 

*  ; 

until_token 

-  ’until 

' ; 

true_token 

-  ’true 

false_token 

-  ’ false 

' ; 

real_token 

-  'real 

' ; 

integer_token 

-  ’integer 

’ ; 

boolean_token 

-  ’boolean 

round_token 

-  ’round 

gt_ffs_token 

-  'gt_ffs 

trunc__token 

-  ’trunc 

' ; 

exp_token 

“  'exp 

' ; 

ln_token 

-  ’in 

’ ; 

sqrt_token 

-  ' sqrt 

’ ; 

sin__token 

-  *sin 

’ ; 

cos_token 

-  ’cos 

tan_token 

-  ’tan 

* ; 

asin_token 

-  'asin 

acos_token 

-  »acos 

’ ; 

atan_token 

-  ’  atan 

send 

-  ’send 

'; 

sendjnsw 

-  ’sendjnsw 

’ ; 

send^lsw 

-  ’send_lsw 

’ ; 

receive 

-  'receive 

’ ; 

receivejasw 

-  ’receive_msw 

’  j 

receive_lsw 

-  ’receive_lsw 

' ; 

proc_reset 

*  ’initialize 

’  ; 

store_function 

-  ' store_function 

’  ; 

store_window 

-  ’ store_window 

read_function 

-  'read__ function 

’  ; 

network 

-  ’network 

’  ; 

host 

-  'host 

’ ; 

host_dav 

-  ’host_dav 

' ; 

host_rfi 

-  ’hostjrfi 

* : 

networkjiav 

-  ’networkjiav 

’; 

networkjrfi 

-  ’networkjrfi 

*; 

real_zero 

-  ’0.0 

'; 

integer_zero 

-  ’0 

’ ; 

array_token 

-  'array 

*  ; 

of__token 

-  ’of 

open_square_bracket  -  *  £ 

close_square_bracket  -  ’  ] 

dot 

-  ’  . 

{symbol  type} 
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real_aymbol_type  -0 ; 

integer_symbol_type  -1; 

real__constant_symbol_type  -2; 

integer__constant_symbol_type  -3; 

label_symbol_type  -4  ? 

procedure_symbol_type  -5; 

standard_procedure_symbol_type  -6; 

function_symbol_type  -7; 

stands rd_function_symbol_type  -8; 

reserved_vord_symbol_type  -9; 

deliittiter_syrabol_type  -10; 

boolean_symbol_type  -11; 

boolean_constant_syrabol_type  -12; 

real_array_symbol_type  -13; 

integer_array_symbol_type  -14; 

boolean_array_symbol_type  -15; 

genera l_syrabol_type  -100; 


(  parameter  type  ) 
call_by_reference  -  0; 
call_by_value  -  1; 

{operator  type} 
addition  -0; 
multiplication  -1; 
subtraction  -2; 
unary _rainus  -  3; 
unary_round  -4; 
unary_trunc  -5; 
division  -6; 
unary^float  -  7; 
rjninus  -  8; 
great  er__than-9 ; 
greater_than_or_equal-10; 
less_than-ll; 
le  s  s_^than_or_equal- 1 2 ; 
equal-13; 
not_equal-14; 
unary_not-15; 
and_operation-16; 
or_operation-17; 
unary_plus-l 8 ; 
unary_index-l 9 ; 
null_operator  -  100; 

{assignment  type} 

R_type  -  2; 

F__type  -  3; 

M_type  -  4;  {  temporary  variable  type  } 


{branch  type} 


if_not_xdav  -  0;  {if  network  has  data  available  } 
if_not  xrfi  -  1;  {  if  network  ia  ready  to  receive  data  } 
if_not_hdav  -2;  (if  host  port  has  data  available  } 
if_not_hrfi  -  3;  {  if  host  port  is  ready  to  receive  data  ) 
ifjeero  -  4;  {if  ALU  result  is  zero  ) 
if_not_zero  -5;  {  if  ALU  result  is  not  zero  ) 
if_negative  -  6;  {  if  ALU  result  is  negative  } 
if_not_negative  -  9;  {if  ALU  result  is  not  negative  } 
if_error  -  10;  {  if  error  occurrs  } 
unconditional  ™  12;  {  unconditional  branch  } 
nojbranch  -7;  {  force  condition  to  be  always  false  ) 

{am2910  opcode) 

J2  -  0;  {  jump  to  zero  ) 

CJS  -  1;  {  eonditonal  jump  to  subroutine  } 

CJP  -  3;  {  conditional  jump  ) 

CRTW  *  10;  {  conditional  return  ) 

CONT  -  14;  {  continue  ) 

{ write_opcode ) 
write_ALU  -  1; 
write_host  -  2; 
write_network  -  3; 
read_function_opcode  -  4; 
store_window_opcode  -  6; 
store_function_opcode  -  7; 

{ALU_opcode) 

Float^add  -  0; 

Float_sub  -  1; 

Float_mult  -  2; 

Float_convert  -  S; 

Fix_convert  -  4; 

{read_opcode> 

load_index  -  1;  {  store  a  value  to  the  index  register  from  the  R-bus  } 
load_host  -  2;  {  store  a  value  to  the  host  fifo  from  the  R_bus  } 

load_network  -  3;  {  store  a  value  to  the  network  fifo  to  the  R_bus  ) 


type 

delimiter_type  -  set  of  char; 

Upper_letter_set_type  -  set  of  char; 

token_type  -  packed  array  [1 . .max_token_length]  of  char; 

character_set  -  set  of  char; 

symbol_pointer  -  Asymbol_record; 

parameter_pointer  -  ~pararoeter_record; 

parameter_record  ** 

record 


id  t  token_type; 


Digital  Emulation  Technology  Laboratory  Final  Report 


id_type  :  longint; 
address  :  longint; 
parameter_type  s  longint; 
next  :  pararaeterjpointer; 
end; 

syrabol_record  - 
record 

name  ;  token_type; 
value  :  longint; 
syrabol_type  :  longint; 
scope  ;  longint; 
const ant_value ;  real ; 
parameter_link  :  pararaeter_pointer; 
next  i  symbol_pointer; 
end; 

express ionjpointer  -  *expression_record; 

expression_record  - 

record 

id  :  token_type; 
id_type  :  longint ; 
operator  :  longint; 
offset  :  longint; 
index  :  token_type; 

address  :  array  CO. .maxjbranch^ pointer]  of  longint; 
up, down, left , right :  expression_pointer ; 
end; 

operand_type  - 
record 

id  :  token_type; 
index  ;  token_type; 
offset  :  longint; 
id_type  :  longint; 
id_address  ;  longint; 
index_address  :  longint; 
end; 
var 

delimiter  :  deliraiter_type; 

Upper_letter_set  ;  Upper_letter_set_type ; 

token  ;  token_type; 

infile  :  file  of  char; 

out file, error file, constant_file  :  text; 

ch  :  char;  {  this  is  to  be  used  only  by  procedure  fetch_jtoken  } 
i  :  longint; 

real_constant_value  ;  real; 
integer_constant_value  ;  longint; 
new_symbol , current_symbol  ;  symbol_pointer; 
first_3ymbol  ;  array [0 . .prime}  of  symbol_pointer; 

symbol_array  j  array  [0..30]  of  token_type;  {  used  to  store  multiple  var  declaration  } 
program_counter, dataram_address, symbol_type, symbol  value  :  longint; 
constant_prograra_counter  ;  longint; 
temp_variable_address  ;  longint; 
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const ant_assignraent_type  :  longint; 
symbol_narae  :  token_type; 
found  :  boolean; 

branch_opcode, am2910_opcode, branch_address, write_opcode,  read_opcode  :  longint; 
microcode_address , AR, AS , IA1 , IAO , Dsel  : longint ; 

AIR, AIS  j  array [0. . 11  of  longint; 

AIF, IA2  :  array [0. .2]  of  longint; 

AF  :  array[0..2]  of  longint; 

13  :  array [0 . . 1]  of  longint; 

ENF_bar, I4,rasv  :  longint; 

mc325_buf fer  :  array  tO . .11  of  longint; 

first_expression, last_expression  ;  array [0 . .raax_expressionJ.evel]  of  expression_pointer; 
new_ expression, current_expression:  expression ^pointer; 
write_lookahead_buffer  :  array  [0..2]  of  operand_type; 
branch_lookahead_buffer  :  array  [0..2]  of  longint; 

{  used  for  pipeline  stage  of  am29325.  Need  to  stuff  nop's  when 
id  needed  for  calculation  has  not  been  calculated  for  at  least 
two  cycles  previously  } 

line_nuraber,percent-variable__counter  :  longint; 

he x_n umber  :  token_type; 

input_filename  :  token_type; 

output_f ilenarae  : token_type ; 

error_filenarae  :  token_type; 

constant_f ilenarae  :  token_type; 

filename  :  token_type; 

expression_type  ;  longint; 

expression_operator  :  array [  0 . .raax_expression_level]  of  longint; 
branch_state  ;  longint;  |  1  ■  branch  if  condition  is  true 

2  -  branch  if  condition  is  false 

3  -  true  and  false  address  jump  may  be  required 

(  last  boolean  expression  evaluated  ) 

4  -  branch  if  condition  is  true 

5  -  branch  if  condition  is  false  } 

expression_number  :  longint;  {  number  used  to  keep  track  of  the  nuraraber  of 

expressions  } 

array_lower_range,  array_upper_range  :  longint; 
debug  ;  boolean; 

index_register  ;  array [0 . ,raax_index_register]  of  token_type; 
stack_pointer  :  longint; 
index_po inter  :  longint; 
procedure_link  :  symbol_pointer; 

current_parameter,new_parameter  :  pa rameter_po inter; 
procedure_level, parameter_type  :  longint; 

local_variable  :  array {0 . .max_procedure_level, 0 . .raax_local_variable]  of  token_type; 

inside_function  block  :  array [0 . .raax_procedure_level]  of  boolean; 

no_local_variable  :  array [0 . .max_procedure_level]  of  longint; 

expression_level  :  longint; 

operand  :  operand_type; 

zero_operand  :  operand_type; 

temp_token  :  token_type; 
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File:  GLOBAL. PAS 
module  global; 

$ include (global . def ) 
private  global 

(  This  module  is  one  of  the  many  datums  showing  that;  } 
{  Intel  PASCAL86  is  quintessentially  bogus  };. 
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File:  HBX_CONV.DEF 
public  hex_conv; 

procedure  wo rd_to_hex (number  s  word;  var  hex_number  ;  token_type ) ; 
Function  Hex_to_word(hex_number  :  token_type)  :word; 
procedure  byte_to_hex (number  i  word;  var  hex_nuraber  :  token_type) ; 
Function  Hex_to_byte (hex_nuraber  :  token_type) ;word; 

procedure  integer_to_hex (number  ;  longint;  var  hex_number  :  token_type) ; 
Function  Hex_to_integer (hex_nuraber  ;  token_type) : longint; 

Function  Hex (data; word) s char; 
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File:  HEX_CONV.PAS 
module  hex_conv; 

$include  (hex_conv.def ) 

^include  (emu_lib.def) 

$include  (bit_func.def) 

^include  ( global. def) 

private  hex_conv ; 

Function  Hex (data sword) : char; 

var  i  :  longint; 

begin 

case  word_and  (data,  OOOfH)  of 

10  :  hex  *A*; 

11  :  hex  fB’; 

12  :  hex  ’C*; 

13  :  hex  fD*; 

14  :  hex  *E*; 

15  :  hex  *F'; 

otherwise  hex  chr(48  +  1); 

end; 

end;  {  Hex  ) 

procedure  byte_to_hex  (number  :  word;  var  hex_number  :  token_type) ; 

var  p,  i  sword; 

begin 

hex_number  blank_token; 
for  p  1  to  2  do 

hex_number [pi  'O'; 

for  i  s-  0  to  1  do 

hex_number [2-i]  hex(word_shr  (number, (4*i) ) ) 

end;  {  of  byte_to_hex  } 

procedure  word_to_hex (number  :  word;  var  hex_number  :token_type) ; 

var  p,  i  :  word; 

begin 

hex_number  blank_token; 
for  p  1  to  4  do 
hex_number [p]  *0'; 

for  i  0  to  3  do 

hex_number[4-i]  hex(word_shl  (number, (4*i) ) ) 

end;  {  of  word_to_hex  ) 

procedure  integer_to_hex (number  :  longint;  var  hex_number  :  token_type) 

var  p,  i  :  word; 

begin 

hex_number  blank_token; 
for  p  1  to  8  do 
hex_number [p]  : -  *  0  f ; 
for  i  0  to  7  do 

hex_number [ 8— i]  hex (dword_shr  (number,  ( 4 * i ) ) ) 


Digital  Emulation  Technology  Laboratory  Final-Report 


147 


end;  {  of  integer_to_hex  } 

function  Hex_to_byte (hex_number  s  token_type) : word; 
label  1; 

var  i, j,m  rword; 

returned_byte  :  word; 
begin 
j  0; 

for  i  1  to  length (hex_nuraber)  do 

begin 

if  hex_number [i]  in  (’A*  then 

hex_number  fi)  char <ord(hex_number (i] )+32) ; 
if  (hex_nuraber[i]  in  or  (hex_number [i]  in  (’a,..,f,n  then 

j  j  ♦  1 

else 

if  (hex_nuraber[i]  <>  'H')  and  <hex_nuraber [i]  <>  ’  ')  then 
begin 

write In  (’  invalid  character  :  ' ,hex_number fi] , *  in  hex  number  * ,  hex_number) ; 
goto  1;  {  exit  ) 

end;  {  of  invalid  hex  character  } 
end;  {  for  i  ..  } 
returned_byte  0; 
for  i  :•  1  to  j  do 
begin 

if  hex_nuraber f i]  in  [ ' 0 * . . * 9f }  then 
m  ord(hex_number (ij )  -48 

else 

m  ord(hex_nuraber (i] )  -  87; 

retumed_byte  word_or  (returned_byte,  (word_shl  (m,  (4*  ( j-i) ) ) ) ) ; 

end;  (  for  i  . . .  ) 

Hex__to_byte  returnedjayte; 

Is  end;  {  Function  Hex_to_byte  } 

Function  Hex_to_word (hex_number  ;  token_type) :vord; 
label  1; 

var  i,j,ra  :  word; 

returned_word  ;  word; 
begin 
j  0; 

for  i  :■  1  to  length (hex_number)  do 
begin 

if  hex_number [ i ]  in  then 

hex_number [ i ]  char (ord(hex_number [i] ) +32) ; 

if  (hex_number [i 1  in  p0f..'9'n  or  (hex_number til  in  [,a,..,f])  then 

j  «-  j  ♦  1 

else 

if  {hex_nuraber { i ]  <>  'H')  and  (hex_number til  <>  '  ’)  then 
begin 

writeln  (’  invalid  character  :  * , hex_number (il , '  in  hex  number  hex_number) ; 
goto  1  t  exit  1 

end;  {  of  invalid  hex  character  J 
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end;  {  for  i  ..  } 
returned_word  0; 
for  i  !■  1  to  j  do 
begin 

if  hex_number[i]  in  [,0,..,9’]  then 
m  ord(hex_number [i] )  -48 
else 

m  s-  ord(hex_nurober li] )  -  87; 

returned_vord  word_or< returned j*ord,  (word_shl  (m,  (4*  ( j-i) ) ) ) ) ; 
end;  (  for  i  . . .  } 

Hex_to_word  :»  returned_word; 

1:  end;  {  Function  Hex_to_word  ) 

Function  Hex_to_integer (hex_nuraber  :  token_type) : longint; 
label  1; 

var  i,j,ra  :  longint; 

retumed_integer  :  longint; 
begin 
j  0; 

for  i  !■  1  to  length (hex_nuraber)  do 
begin 

if  hex_nuniber [i]  in  t’A’./F')  then 

hex_nuraber (i)  char  (or d(hex__n umber  [i] ) +32) ; 

if  (hex_number (i]  in  or  (hex__number [i]  in  then 

j  j  +  1 
else 

if  (hex^number [i]  <>  *H*)  and  (hex_number [i]  <>  *  ')  then 
begin 

writeln  {'  invalid  character  :  * ,hex_number (i) , *  in  hex  number  hex_number) ; 
goto  1;  {  exit  ) 

end;  (  of  invalid  hex  character  ) 
end;  (  for  i  . .  } 
returned_integer  0; 
for  i  :•  1  to  j  do 
begin 

if  hex_number ( i J  in  [,0*..,9']  then 
m  ord (hexjnumber (i] )  -48 

else 

m  ord (hexjnumber [il )  -  87; 

returned__integer  dword_or  (returned_integer,  (dword_shl  (m,  (4*  ( j-i) ) ) ) ) ; 
end;  {  for  i  ...  } 

Hex_to_JLnteger  returned_integer; 

1:  end;  (  Function  Hex_to_integer  }. 
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File:  IEEE_CNV.DEF 
public  ieee_cnv; 

procedure  real_to_ieee (value : real; var  rasw, lsw sword) ; 
function  ieee_to_real (msw, lsw sword) sreal; 
function  longint_to_real<lw  :  longint) s real; 
function  real_ to_longint ( sx  :  real) : longint; 
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Files  IEEE_CNV.PAS 
module  ieee_cnv; 

$include  (bit_func.def) 

^include  (ieee_cnv.def) 

private  ieee_cnv; 
type 

real_intemal_type  -  record 

case  internal_type :  boolean  of 
true  :  (real_value  ;  real); 
false  :  (word_value  :  array  [1..2J  of  wprd); 
end; 


procedure  real_to_ieee; 
var 

x  :  real_intemal_type; 
begin 

x.real_value  value; 

maw  x. vord_value  [2] ; 

Isw  : -  x . word_value [  1  ] ; 
end; 

function  ieee_to_real; 
var 

x  :  real__internal_type; 
begin 

x.word_value [2)  s-  msw; 
x.word_value[l]  lsw; 

ieee_to_real  x.real_value; 

end; 

function  longint_to_real (lw  :  longint) : real; 
var 

x  :  real_internal_type; 
begin 

x.wor devalue [2]  dword_shr(lw,16); 
x.word_value[l)  dword_and(lw, OOOOffffH) ; 

longint_to_real  x.real_value? 

end;  {  of  longint__to_real  } 

function  real_to_longint (sx  :  real) : longint? 
var 

x  :  real_internal_type; 
lw  :  longint; 
begin 

x.real_value  sx; 

Iw  x.word_value[2] ; 

lw  dword_or (dword_shl {lw, 16) , x. word_value [1] ) ; 
real_to_longint  lw; 
end; .  {of  real_to_longint  } 
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File:  IFJIHILE.PAS 

procedure  r ever se_branch_direct ion (var  address  i  longint) ; 
begin 

if  (branch_lookahead_buffer Il]-if_zero)  then 
branch_lookahead_buf f er [ 1 ] :-if_not_zero 

else 

if  (branch__lookahead_buff  er  [1  ]  -if_not_zero)  then 
braneh_lookahead_buffer (1] if_zero 
else 

if  (branch__lookahead_buf  f  er  1 1  ] -if_nega t ive )  then 
branch_lookahead_buffer (1]  :-if_not_negative 
else 

if  (branch_lookahead_buffer[l]-if_not_negative)  then 
branch_lookahead_buf fer [1] :~if_negative; 
address  -address; 
end?  {  of  reverse_branch_direction  } 

Procedure  while_statement ; 

var  address  :  array  [1. .max_branch_pointer]  of  longint; 
starting_address,i  :  longint; 

initial_index_register  :  array  1 0 . ,max_index_register]  of  token_type; 
begin 

fetch^token; 

clear  jpipeline_stage; 

start ing_addr ess  program_counter; 

for  i  0  to  max_index_register  do 

begin 

initial_index_register [i]  index_register U] ; 
end; 

boolean_expr es  sion ; 

{  store  the  branch  address  before  another  compound  expression  is  called  } 

i  1; 

repeat 

address  I i]  first_expression(expression_level] * .address [i] ; 

i  i+1; 

if  i  >  raax__branch_j>ointer  then 

write_error( 'maximum  branch  pointer  exceeded  token); 

until  (addressli-l]  -  7f ffh) ; 
if  (i>2)  then 

if  (address [i-2]  >  0)  then  reverse_branch_direction (address [i-2] )  ; 

{  back  patching  branch  address  with  true  condition  } 
i  It 

repeat 

if  (address [i]  >  0)  and  (address [i]  <>  7fffh)  then 
begin 

clear_pipeline_stage  ? 

writeln(outfile, 'b  address [i] +2, '  ' , program_counter) ; 
end; 

i  i+1? 

if  i  >  max_branch_po inter  then 

write  error ( ’maximum  branch  pointer  exceeded 


' , token) ; 
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until  (address [i-1]  -  7fffh); 
verify__token  (token,  do_token) ; 
corapound__statement ; 

(restore  the  index  register  to  its  initial  state} 

for  i  0  to  max_index_register  do 

begin 

if  initial_index_register [i]  <>  index_register ti]  then 
begin 

if  initial_index_register [i]  <>  blank_token  then 
load_index_register  (initial_index_jregister(i] ) ; 
index_register(i]  s-  initial_J.ndex_register  (i] ; 
end; 
end; 

if  write_lookaheadjouffer [1J .id  <>  blank_token  then  generate_Nop; 
writeln( out file, * ; ' ,program_counter, * t  goto  * , start ing_address) ; 
microcode_address  program_counter ; 
branch_address  :•  starting_address; 

AH2910_opcode  CJP; 

branch_opcode  unconditional; 

output__raicrocode_f  ield ; 
program_counter  program_counter  +  1; 
i  1; 

while  (addressfi]  <>  7fffh}  do 
begin 

if  address [i]  <  0  then 

writeln(outfile, *b  *,abs (address (i] ) +2, •  ’ ,programj=ounter) ; 
i  i+1; 

if  i  >  max_branch_pointer  then 

write_error ( ’maximum  branch  pointer  exceeded  ', token); 

end; 

end;  {  of  while_stateraent  } 

Procedure  if_statement; 

var  address  :  array  (1. .raaxjaranchjpointer]  of  longint; 
endif_address, else_address, i  ;  longint; 

initial_index_register  :  array  [0 .  .raax_index_registerl  of  token_type; 

begin 

fetch_token; 

boolean_expression; 

{  store  the  branch  address  before  another  compound  expression  is  called  } 

i  1; 

repeat 

address [i]  :«  first_expression[expre3sion_level] address [ij ; 
i  i+1; 

if  i  >  max_branch__pointer  then 

wr it e_err or (’maximum  branch  pointer  exceeded  ' , token); 

until  (address (i-1)  -  7fffh) ; 
if  (i>2)  then 

if  (address [i-2 ]  >  0)  then  reverse_branch_direction (address [i-21 ) ; 

(  back  patching  branch  address  with  true  condition  ) 
i  1; 
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repeat 

if  (address [ij  >  0)  and  (address (ij  <>  7fffh)  then 
begin 

clear_pipeline_stage; 

vriteln( out file, »b  address [ij +2, •  • ,prograra_counter) ; 

end; 

i  i+1: 

if  i  >  raax_branch_po inter  then 

wr it e_err or <• maximum  branch  pointer  exceeded 
until  (address (i-1]  -  7fffh) ; 
verify__token (token,  then__token) ; 
for  i  0  to  max_index_register  do 
begin 

initial_index_register [i]  index_register [i] ; 
end; 

compound^statement; 

(restore  the  index  register  to  its  -initial  state) 

for  i  0  to  max_index_register  do 

begin 

if  initial_index_register[i]  <>  index_register (i]  then 
begin 

if  initial_index_register[i]  <>  blank_token  then 
load_index_register (initial_index_register (i] )  ; 
index_registar(i)  initial_index_register (i) ; 
end; 
end; 

if  token  -  else^token  then 
begin 

if  write_lookahead_buf ffer [1] .id  <>  blank_token  then  generate_Nop; 
endif_address  program_counter; 

am2910_opcode  CJP; 

branch_lookahead_buffer (0)  unconditional; 
microcode_address  program_counter ; 
output jmicroeode_f ield; 
program_counter  program__counter  +  1; 
else_address  prograra_counter ; 
compoun  d_statement; 

(restore  the  index  register  to  its  initial  state) 

for  i  0  to  max_index_register  do 

begin 

if  initial_index_register (i]  <>  index_register (i)  then 
begin 

if  initial^ index_register (i]  <>  blank_token  then 
load_index_register(initial_index_register (i) ) ; 
index__register  [i]  initial_index_register  [i] ; 
end; 
end; 

clear_pipeline_stage; 

writeln (outf ile, ’b  * , endif_address, *  ’ , program^counter) ; 
end 


token) ; 


else 
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begin 

clear_pipeline_stage ; 
else_address  :«  prograra_counter; 
end; 
i  s-  1; 

while  (address (il  <>  7fffh)  do 
begin 

if  address [i]  <  0  then 

vriteln (outfile, *b  * ,abs (address lij) +2, '  ’ , else_address) ; 
i  i+1; 

if  i  >  raax_branchjpointer  then 

write_error ( 'maximum  branch  pointer  exceeded  *, token); 

end; 

end;  {  of  if_statement  ) 

Procedure  repeat_statement; 
var  address  ;  longint; 

starting_address, i  :  longint; 

initial_index_register  :  array(0. .max_index_register]  of  token_type; 
index_po inter  :  longint; 
begin 

clear_pipeline_stage ; 
starting_address  prograra_counter; 

{  save  the  state  of  the  index  register  ) 
for  i  0  to  max_index_register  do 
begin 

initial_index_register [i]  index_register (ij ; 

end; 

compound_st at ament; 
while  tokenCl]-*;*  do 
begin 

corapound_st at ement ; 
end; 

verify__token  (token,  until_token) ; 

fetch^token; 

boolean_expression; 

{  back  patching  branch  address  ) 

i  1; 

repeat 

if  (first_expression[expression_level) A. address [i)  <>  7fffh)  then 
begin 

if  (first_expression(expre33ion_levelI‘‘' .address [i+1] -7 fffh)  and 
(first_expres3ion(expression_level] address fi] >0)  then 
begin 

address  fir3t_expression [expression_level ] * . address [i] ; 
reverse_branch_direction (address) ; 

first_expressiontexpression_level] ''.address  [i]  address; 
end; 

if  (first_expression[expression_level] * . address [i]  <  0)  then 

writeln (outfile, 'b  -first^expression [expression^level] A . address [i] +2, *  ' , starting_address) 


else 
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writ eln( out file, 'b  first_expression[expression_leveiP .address [i] +2,  *  1 ,program_counter) 

end; 

i  i+1; 

if  i  >  max_branch_po inter  then 

writ e_err or {'maximum  branch  pointer  exceeded  ', token); 

until  {first_expression{expression_level} * .address Ji-1]  -  7fffh); 

{restore  the  index  register  to  its  initial  state) 

for  i  0  to  max_index_register  do 

begin 

if  initial_index_register[i1  <>  index__register  (i]  then 

begin 

if  initial_index_register [i]  <>  blank_token  then 
load_index_register{initial_index_register[i] ) ; 

index_register [i]  initial_index_^register  [i] ; 

end; 

end; 


end;  {  of  repeat__statement  } 
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File:  INIT.DEF 
public  init; 
type 

pac81  -  packed  array  11.. 81]  of  char; 

procedure  initialize; 

procedure  prograra_heading_block; 

procedure  insert_stdjprocedure_to_symbol_table ; 

procedure  insert_*tandard-function-to_syntbol_table; 

procedure  insert_jreserved_word_to_symbol_table : 

procedure  in3ert_delimiter_to_syrabol_table ; 
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Files  INIT. PAS 
module  init; 

^include (init . def) 

$ include (global . def) 

$include ( f etch_t k . def) 

$include ( symbol_t .def) 

$ include (utility .def) 

^include (code_gen . def) 

$include (expr sion . def ) 

$include (erau_lib.def ) 
public  UDIcall; 

function  dqgetargument  (  var  string81  :  pac81;  var  w  ;  word) 
function  dqattach  (  var  token  :  token_type;  var  error  s  word) 
procedure  dqdetach  (connection  :  word;  var  error  :  word) ; 
procedure  dqexit  (completion__code  :  word) ; 

private  init; 

procedure  insert_stdjprocedure_to_3ymbol_table ; 
begin 

symbol_type  standard__procedure_syrabol_type; 
insert_symbol  (send,  symbol_type,  symbol__value) ; 
insert_syrabol(send_msw, symbol_type, syrabol_value) ; 
insert_syrabol (send_lsw, symbol_type, symbol_value) ; 
insert_symbol (receive, symbol_type, symbol_value) ; 
insert_syrabol (receive^rasw, symbol_type, symbol^value) ; 
insert_symbol  (raceive_lsw,  symbol_type,  symbol_value) ; 
insert_symbol (store_function, symbol_type, symbol_value) ; 
insert_symbol  ( store_window,  symbol_type,  symbol_value )  ; 
insert_symbol (read_function, symbol_type, symbol_value) ; 
insert_symbol (proc_reset, syrabol_type, symbol_value) ; 
insert_symbol  (gt_ffs_token,  symbol_type,  syinbol_value) ; 
end; 

procedure  insert_standard_function_to_symbol_table; 
begin 

symbol_type  standard_function_symbol_type; 
insert_symbol (trunc_token, syrabol_type, symbol_value) ; 
insert_syrabol (round_token, symbol_type, symbol_value) ; 
insert__symbol  <exp_token,  symbol_type,  symbol_value) ; 
insert_syrabol (ln_token, symbol_type, symbol_value) ; 
insert_syrabol (sqrt_token, symbol_type, symbol_value) ; 
insert_3ymbol (sin_token, symbol_type, symbol_value) ; 
insert_symbol (cos_token, symbol_type, symbol_value) ; 
insert  jsymbol (tan_token, symbol_type, symbol_value) ; 
insert  symbol <asin_token, syrabol_type, symbol_value) ; 
insert_3ymbol (acos_token, symbol_type, symbol_value) : 
insert_symbol (atan_token, symbol_type, symbol_value) ; 


schar; 

:  word 


end; 
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procedure  inserter eserved_word_to_symbol_table; 
begin 

syrabol_type  reserved_word_symbol_type; 
insert_symbol (program_heading, symbol_type, symbol^value) ; 
insert_syrebol (procedure_heading, symbol_type, symbol_value) ; 
insert_symbol (function_heading, symbol_type, symbol_value) ; 
insert_syrabol (var_declaration, syrabol_type, symbol_value) ; 
insert_symbol (const_declaration, symbol_type, aymbol_value) ; 
insert_symbol (type_declaration, symbol_type, symbol_value) ; 
insert^symbol  (begin_token,  syrabol_type,  symbol_value)  ; 
insert_3yrabol (end_token, syrabol_type, syrabol_value) ; 
insert_symbol (if_token, symbol_type, symbol_value) ; 
inaert_syrabol (then_token, symbol_type, syrabol_value) ; 
insert_symbol (else_token, ayrabol_type, symbol_value) ; 
insert_3yrabol  (while_token,  symbol_type,  symbol_value) : 
insert_syrabol(repeat_token,  »ymbol__type,  syrabol^value) ; 
ins ert— symbol (until_token, syrabol_type, symbol_value) ; 
insert_syrabol(do_token, symbol_type, syrabol_value) ; 
insert_syrabol  (real_token,  syrabol_type,  symbol__yalue) ; 
insert^syrabol (integer_token, symbol^ type, syrcbol_value) ; 
insert_symbol (boolean_token, symbol^type , symbol_value) ; 

±nsert_symbol (host, symbol_type, syrabol_value) ; 
insert_symbol (network, syrabol_type, symbol_value) ; 
insert_aymbol (greater_than_token, syrabol_type, symbol_value) ; 
insert^ symbol (greater_than_or_equal_token, symbol_type, symbol_value) : 
insert_symbol (less_than_token, symbol_type, symbol_value) ; 
insert_symboX (less_than_or_equal_token, symbol_type, symbol_value) ; 
insert_symbol  (not_equal_token,  syrabol_type,  symbol_value) ; 
insert_symbol(equal_token, syrabol_type, symbol_value) ; 
insert_symbol  (not_token,  symbol_type,  syrabol_value)  ; 
insert_symtsol  (and_token,  symbol_type,  symbol_value) ; 
insert_aymbol (or_token, aymbol_type, symbolvalue) ; 
insert__symbol  (array_token,  symbol_type,  syrabol_value)  ,* 
insert_symbol (of_token, aymbol_type, aymbol_value) ; 
insert_symbol (to_token, symbol^ type, symboX_value) : 
insert^syrabol (for_token, syrabol_type, symbol_value) ; 
end; 

procedure  insert_delimiter_to_syrabol_table; 
begin 

symbol _type  :  -  de limit er_symbol_type; 
insert_syrabol (multiply_token, symbol_type, syrabol_value) ; 
insert_symbol (divide_token, symbol_type, 3ymbol_value) ; 
insert_syrabol  (add_token,  symbol_type,  symbol_value)  ; 
insert^aymbol  (minus_token,  symbol_type,  symbol_vaXue)  ,* 
insert_3ymbol  (period,  symbol_type,  symbol__value) ; 
inaert^symbol (comma, symbol_type, symbol_value) ; 
insert_aymbol  (percent_token,  symbol_type,  symbol_value) ; 
insert_symbol (open_parenthesis, symbol_type, symbol_value) ; 
insert_symbol  (close_parenthesis,  symbol__type,  symbol_value) ; 
insert_symbol  (semicolon,  symbol_type,  symbol_value)  ,* 
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insert_syrabol  <open__bracket,  symbol_type,  symbol_value) ; 
insert_symbol(elose_bracket,  symbol_type, symbol_value) ; 
insert_syrabol  (close_square_bracket, symbol_type,  symbol_value)  ; 
insert_syrabol  (open_square_bracket,  syrabol_type,  symbol_value)  ; 
end; 

procedure  initialize; 
var  i,j  :  longint; 

string81  :  pac81;  {  These  three  variables  are  used  by  } 
w  :  word;  {  udi  system  call  DOGETARGUMENT .  See  page  } 

c  :  char;  {  32  of  UDI  System  Calls  IRMX  Vol.  2  ) 

connection, error  :  word;  {  Used  by  dqattach  and  dqdetach.  See  pg. 

12  &  25  of  UDI  System  Calls  IRMX  Vol.  2  } 

corapletion_code  :  word;  {  Used  by  dqexit.  See  pg.  26  UDI  System 

Calls  IRMX  Vol.  2  } 


begin 

{  Dqgetargument  emulates  turbo  pascal's  ability  to  get  parameters  off 

of  the  command  line.  See  pg.  32  of  UDI  System  Calls  IRMX  Vol.  2  } 

c  dqgetargument {st ring 81, w) ; 

for  i  :■  0  to  prime  do 

begin 

first_symbol[i]  nil; 
end; 

procedure_level  :■*  0; 

clearscreen; 

gotoxy (5,2) ; 

writeln (version) ; 

gotoxy (S, 5) ; 

write ( *  input  file  :  ’ ) ; 

filename  blank_token; 

{  This  block  of  code  enables  the  user  to  type  in  the  name  of  the  file 
with  or  without  the  .pas  extent ion.  } 

if  ord(string81(l] )  -  0  then 
begin 

read_token  (temp_token)  ; 
i  1; 

while  (i  <»  max_token_length)  and  (temp_tofcen(il  <>  '.')  do 
begin 

filename(i]  temp_token[i] ; 
i  i  +  1 
end 
end 
else 
begin 
i  2; 
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while  («tring81 [i)  <>  *.♦)  and  (i  <-  (ord (string81 [1] ) )  +  1)  and 

(i  <-  max_token_length)  do 

begin 

filename ti-11  string81[il; 
i  i  +  1 

end; 

write_token( output,  filename) 
end; 

debug  false; 

gotoxy {5,24) ; 
write (0); 
line__nuraber  1; 
input_filenarae  j-  filename; 
concat  (input_filenarae,  *,pas 
output_filenarae  filename; 
concat  < out put__f i lenarae ,  '  .fpp 
error_filename  filename; 
concat  (error_filename,  '.err 
const ant_filename  filename; 

concat  (constant_filenarae,  * .hct 

{  Temp_token  is  manipulated  like  so  in  the  next  seven  lines  because 
the  UDI  call  dqattach  uses  a  different  string  format  than  Pascal-86. 
Dqattach  requires  that  the  string  length  be  stored  in  string[l]  } 

terap_token  input_filename; 
j  length (terap_token) ; 
if  j  -  raax_token_length  then 

.  j  i-  j  -  1# 

for  i  j  downto  1  do 

temp_token(i+l]  temp_token[iJ ; 

temp_token{l]  chr(j); 

(  Dqattach  is  used  for  an  indirect  pupose  here,  which  is  to  detect 
whether  or  not  the  file  exists.  If  it  does  it  detaches  the  file  with 
dqdetach  (so  the  file  is  its  original  state  be  for  dqattach  was  called) . 

If  the  file  does  not  exist,  the  error  handling  occurs  here,  not  later  with 
a  cryptic  Pascal-86  message.  See  pp.  12  i  25  in  UDI  System  Calls  - 
IRMX  Vol.  2 

connection  dqattach  (temp_token,  error); 
if  error  <>  0  then 
begin 

gotoxy  (5,12); 

write_token  (output,  temp__token)  ; 
writeln  <*  does  not  exist.*); 
gotoxy  (5,24); 

dqexit  (completion_code)  {  halt  } 
end; 

dqdetach  (connection  , error) ; 
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{  These  next  four  lines  insert  an  ascii  nul  to  the  end  of  the  string  so 
that  Pascal-86  knows  where  to  truncate  the  string  for  the  reset  and 
rewrite  statements  to  follow.  See  pg.  8—17  Pascal-86  User's  Guide  Rev.  5  } 


input_filenarae [length (input_f ilename)  +  1]  chr(O); 

output_f ilename [ length (output_f  ilename)  +11  chr(O); 

error_filename [length (err or_f ilename)  +  1]  :*  chr(O); 

constant_f ilename [ length ( const ant_f ilename)  +  11  chr(O): 

reset  (infile, input_f ilename ) ; 

rewrite  ( out  file , out put_f ilename ) ; 

rewrite  (errorfile, error_filename) ; 

rewrite  (conatant_fil0,constant_filenarae) ; 

ch  infile-'; 

get  (infile) ? 

if  (ord(ch)  >-  65)  and  (ord(ch)  <-  90)  then  ch  char (ord (ch) +32) ; 
write (errorfile, ch) ; 
writeln(outfile,  ' ; 

writeln( out file. 1 ;  p  b  e 

writ eln< out file, * ;  I  ! 

writeln( out file, *;  c  2  a 

writeln(outfile, n  9 
writeln(outfile, * ;  t  1 

writeln(outfile, ';  r  0 

writelnt out file, ’; 
with  2ero_operand  do 
begin 

id  blank__token; 
id(l)  s-  'O'; 

id_type  real_symbol_type; 
index  blank_token; 
offset  :•  0; 
id_address  1; 
index_address  0; 
end; 

for  i  i-  0  to  2  do 
begin 

write_lookahead_buffer [il .id  blank_token 
branch  lookahead_buffer [ i  1  7fffH; 


r  n  m 

a  b  w  D  d  f  c 

d  1  I  s  |  1  3 

d  o  oeobll  2 

r  p  p  1  p  a  4  3  5 


mill 
S  A  A  A  A  A  A 
AS  w  2  1  0  IF  IR  IS 


AF til  0; 

end; 

for  i:-0  to  1  do 
begin 

13  [il  0; 

rac325_buffer[i]  0? 
end; 

express ion_number  i-  1; 
for  i  i-  0  to  1  do 
begin 

AIS [i]  7fffH; 

AIR [il  7fffH? 
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end; 

for  i:-  0  to  2  do 
begin 

IA2ti]  s-  0; 

AIFti]  7fffH; 

with  vrite_lookahead_buffer!i]  do 
begin 

id  blank__token; 
id_type  0; 
index  blanket oken; 
offset  0; 
end; 
end; 

for  i  0  to  raax_index_register  do 
index^register [ij  blank^token; 
upper_letter_set  [ * A* . . »2  *  1 ; 

delimiter 

t*»  *#  *<**')•. f**«  *+*#  *-f, */*, '  *# f ; *  * 

♦  *>\'<\ 

constant_program_counter  0; 
stack_j>o  inter  datarara_address_limit; 

{assign  permanent  constant  values  for  0.0,  0,  1.0,  and  1} 
datarara_address  1; 

str_real <0.0, token) ; 
real_constant_value  ;«  0.0; 

insert_symbol (token, real_constant_symbol_type, syrabol_value) ; 
dataram_address  1; 

insert^ symbol  ( false_token, boolean_constant_syrabol_type,  symbol_value)  ; 

dataram_address  :■*  1; 

integer_constant_value  0; 

terap^token  blank_token; 

temp_tokentl]  *0'; 

insert_symbol  (temp_token,  integer_constant_symbol_type,  symbol_value) ; 
terap_token  blank_token; 

temp_token [ 1 I  ’O’; 

declare_constant (1, integer_constant_symbol_type, temp_token) ; 
dataram_address  3; 
str_real (1 . 0, token) ; 
real_constant_value  1.0; 

insert_symbol  (token,  real__constant_syrabol_type,  symbol_value) ; 
dataramaddreas  3; 

insert_syrabol (true_token,boolean_constant_symbol_type,  symbol_value) ; 
integer_constant__value  1; 

dataram_addreas  3; 
temp_token  blank_token; 

t emp_token [ 1 ]  : -  *  1 • ; 

insert_symbol (temp_token, integer_constant_symbol_type, symbol_value) ; 
temp_token  blank_token; 

temp_token ( 1 ]  : -  *  1  * ; 

declare_constant (3, integer_conatant_symbol_type, temp_token) ; 
prograra_counter  0; 
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reset_microcode_field; 

generate_Nop; 

insert_std_j>rocedure_to_symbol_table; 

insert_3tandard_function_to_symbol_table; 

insert_r e served_yor d_to__syrabo l_t abl e ; 
insert_deliraiter_to_symbol_table ; 
create_expre3sion (new_expre33ion) ; 
expression_level  0; 

fir3t_expression[expre33ion_level]  new_expression; 
no_local_variable [ 0 ]  0; 

reset_temp__variable_address; 
for  i  j-  0  to  max_procedure_level  do 
inside_function_block(i}  false; 
end;  {  of  initialize  } 

procedure  prograra__heading__block; 
begin 

fetch__token;  {program  name} 
fetch_token;  {  {or;  > 

if  (token  <>  open_parenthesis)  and  (token  <>  semicolon)  then 
begin 

writeln{ error file) ; 

writeln(errorfile, * ! ! ! !  syntax  error  " ("  or  expected') 

•rror_found; 
end; 

if  {token  <>  semicolon)  then 
begin 

if  (token  -  open_parenthesis)  then 
begin 

fetch_token;  (  input  ) 
fetch_token; 
if  (token-  comma)  then 
begin 

fetch_token; 
fetch_token;  {  output  ) 
end; 

verify_token (token, closejparenthesis) ; 
end; 

fetch_token; 

verify_token (token, semicolon) ; 
end; 

end;  (  of  program  heading  section  } . 
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File:  IO-DEF 
public  io; 

Procedure  sendjprocedure; 
Procedure  receive_procedure; 
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Fllai  10. FAS 
module  io; 

$inelude (io.de f) 

$ include < global. def) 

$inelude ( f etch_tk . def) 

$include (arith . def) 

$ include (syinbol_t .def) 

$ include (utility . def ) 

$include (code_gen . def) 

$ include ( emu_lib -def) 

private  io; 

procedure  generate_send ( device : token_type ; operand  :  operand_type ; 

order :longint) ; 

begin 

check_F_bus (operand) ; 

operand_string  (operand,  terap_token) ; 

write (out file, ' ; 1 , prograra_counter, * :  fetch ( ’ ) ; 

write_token  (outfile,  terap_token) ; 

writeln  (outfile,  MM; 

assign_S_bus (operand) ; 

Assign_R_bus (operand) ; 
maw  order; 

microcode_address  prograra_counter; 
output_microcode_field; 
prograra_counter  prograra_counter  +  1; 
operand^atring  (operand,  temp_token) ; 
if  order  -  1  then 
begin 

write (outfile, ’ ; ' , prograra_counter ) ; 
write (outfile, * :  send_msw( ’ ) ; 
write_to)cen  (outfile,  device); 
write (outfile,  *,'); 
write_token  (outfile,  temp_token)  ; 
writeln  (outfile,  M.M 
end 
else 
begin 

write (outfile, ’ ; ’ , program_counter) ; 
write (out file, M  send_lsw(M ; 
write_token  (outfile,  device); 
write (out file,  ','); 
write_token  (outfile,  temp_token) ; 
writeln  (outfile,  MM 
end; 

am2910__opcode  CJP; 
if  device  -  host  then 
begin 

branch__opcode  if_not_hrfi; 
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read_opcode  load_host; 

end 
else 

if  device  -  network  then 
begin 

branch^opcode  iff_not_xrfi; 
read_opcode  load_network; 

end 
else 

write_error( * unknown  send  device  :  ' , device); 

branch_address  prograra_counter; 
maw  order; 
assign_S_bus (operand) ; 
assign_Rj5us (operand) ; 
microcode_address  s-  program_counter; 
outputjnicrocode_field; 
prograra_counter  prograra_counter  +1; 
end;  (  of  generate^send  } 


procedure  generate_receive (device ttoken_type? operand  :  operand_type; 

order : longint) ; 


begin 

generate_nop; 
clear_pipeline_st age ; 
operand_string (operand, temp_token) ; 
if  order  -  1  then 
begin 

write (outfile, * ; * , program_counter , • :  receive_msw ( * ) ; 
write_token  (outfile,  device) ; 
write  (outfile, * , * ) ; 
write_token  (outfile,  temp_token) ; 
writeln (outfile, r ) * ) 
end 
else 
begin 

write (outfile, * ; * , prograra_counter , * ;  receive_lsw ( ' ) ; 
write_token  (outfile,  device); 
write  (outfile, * ,  • ) ; 
write_token  (outfile,  temp_token) ; 
writeln  (outfile, f ) * ) 
end; 

am2910_opcode  CJP; 
if  device  —  host  then 
begin 

branch_opcode  ifjnot_hdav; 

write_opcode  write_host; 
end 
else 

if  device  -  network  then 
begin 

branch_opcode  if_not_xdav; 
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write_opcode  write_netvork; 
end 
else 

write_error (* unknown  receive  device  :  device); 

branch_address  prograra_counter; 

nsw  order? 
assign_F_bus (operand) ; 
raicrocode_address  prograra__counter; 
output_microcode_field; 

program  counter  prograra_counter  +  1; 
end;  {  of  generatereceive  ) 

Procedure  send_proeedure ; 
var 

io_operand  :  operand_type; 
integer_operand  :  operand^ type? 
device  :  token_type; 
send_command  :  token_type; 
i  ;  longint; 
begin 

clear_tercp_index ; 
reset_terap_variable_addres3; 
send_coramand  token; 
fetch_token; 

verify__token  (token,  open_parenthesis)  ; 

fetch_token; 

device  token; 

fetch_token; 

verify^token (token, comma) ? 
fetch_parameter (io_operand) ; 

find_symbol(io_operand.id,io_operand.id_type,io_operand.id_address, found) ; 

if  not  found  then 

-  write_error< ’unknown  id:  ’ , iojaperand. id) ; 

io_operand.index_addres3  assign_index(io_operand. index) ; 
symbol_type  io_operand.id_type? 
if  (symbol_type  -  real_symbol_type)  or 

(symbol_type  -  real_constant_symbol_type)  or 
(symbol_type  -  real_array_symbol_type)  or 
(symbol_type  -  boolean_syrabol_type)  or 
(symbol_type  -  boolean_constant_symbol_type)  or 
(symbol^type  -  boolean_array_symbol_type)  then 
begin 

if  (write_lookaheadjouffer (11 .id  <>  blank_token)  then  generate_nop; 
if  (write_lookahead_buffer (0) . id  <>  blank_token)  then 
if  (write_lookahead_ buffer [0] .id  -  io_operand.id)  then 
if  (write_lookahead_buffer [0] . id  -  io_operand. id)  then 

if  (write  lookahead_buffer(0] .index  -  io_operand.  index)  then 

if  (write_lookaheadjDuffer [0] .offset  -  io_operand. offset)  then 
generate_nop; 

if  (send_command  -  send_rasw)  or  ( send_command  -  send)  then  generate_send (device, io_operand, 1) 
if  { send_command  -  send_lsw)  or  (send_command  -  send)  then  generate_send (device, io_operand, 0) 
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end 

else 

if  ( symbol _type  -  integer__syrabol_type)  or 

{ syrabol^type  -  integer_constant_symbol_type)  or 
(syrabol_type  -  integer_array_symbol_type)  then 
begin 

assign_temp_pararaeter (integer_operand, integer_symbol_type) ; 
generate_ALU_operation (integer_operand, io_operand, zero_operand, unary_round) ; 
delete (integer_operand. id, 1, 1) ; 

val_integer (integer_operand.id, integer_operand.id_address, i) ; 
clear_pipeline_stage; 

if  ( send^command  -  send_rasw)  or  (send_command  -  send)  then 
generate_send (device, integer_operand, 1) ; 
if  ( send_coranand  -  send_lsw)  or  (send_coiranand  -  send)  then 
generate_send (device, integer_operand, 0 ) ; 

.  end 
else 
begin 

write^error ( ' 10  not  allowed  * , token) ? 

end; 

verify_token (token, close^parenthesis) ; 
end;  {  of  send_procedure  ) 

Procedure  receive_procedure; 
var 

io_operand  :  operand_type; 
device  :  token_type; 
receive_eomraand  ;  tokentype; 
begin 

clear_t erap_index ; 
reset_temp_variable_address; 
receive_coraraand  ;•  token; 
fetch_token; 

verify_token (token, openjparenthesis)  ; 

fetch_token; 

device  token; 

fetch_token; 

verify__token (token,  comma) ; 
fetch_parameter (io_operand) ; 
if  io_operand.id{l]  -  ’#*  then 

write_error (* simple  variable  is  expected  :  device); 

find_symbol (io_operand. id, io_pperand.id_type,io_operand.id_address, found) ; 
if  not  found  then 

write_error( 'unknown  id;  * , io_operand. id) ; 

io_operand.index_address  assign_index (io_operand. index) ; 

symbol_type  io_operand.id_type; 
if  (symbol_type  -  real_symbol_type)  or 

(symbol_type  -  real_constant_symbol_type)  or 
( symbol_type  -  real_array_symbol_type)  or 
(symbol_type  -  boolean_jjymbol_type)  or 
( symbol_type  -  boolean_constant_3ymbol_type)  or 
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<syrabol_type  -  boolean_array_symbol_type)  then 
begin 

if  (receive_comraand  -  receive_msw)  or  <receive_comraand  -  receive)  then  generate_receive (device, io_operand, 1) ; 

if  (receive_comraand  -  receive_lsw)  or  (receive_command  -  receive)  then  generate_receive (device, io_operand, 0) ; 

end 

else 

if  (syrabol_type  -  integer_syrabol_type)  or 

(symbol_type  -  integer_constant_3ymbol_type)  or 
< symbol_type  -  integer_array_symbol_type)  then 
begin 

if  (receive  command  **  receive  resw)  or  (receive__command  ~  receive)  then  generate_receive (device, io_operand, 1) ; 

if  (receive  command  -  receive__lsw)  or  (receive__command  -  receive)  then  generate_receive  (device,  io_operand,  0)  ; 

if  (receive^command  -  receive)  or 

(receive_command  -  receive_lsw)  then 

generate_alu_operation(io_operand, io_operand, zero_operand, unary_float) ; 

end 

else 

begin 

vrite__ error ( * IO  not  allowed  *  *  token) ; 

end; 

verify_token (token, close_parenthesis) ; 
end;  (  of  receive_procedure  }. 
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Pile:  LIB.OEF 


public  lib; 
procedure 
procedure 
procedure 
procedure 
procedure 
procedure 
procedure 
procedure 
procedure 
procedure 
procedure 
procedure 
procedure 


funct ion_t rune (var  fx  :  operand_type;  x  :operand_type) ; 

function_round(var  fx  :  operand_type;  x  :  operand_type ) ; 

generate_gt_ff a ( funct ion_number  : integer; f, r, a  :  operand_type) ; 

function_exp<fx,x  :  operand_type) ; 

funct ion_ln ( fx, x  :  operand_type ) ; 

function_aqrt ( fx, x  :  operand_type ) ; 

function_ain ( fx, x  :  operand_type) ; 

function_coa<fx,x  :  operand_type) ; 

funct ion_tan ( f x, x  :  operand_type) ; 

funct ion_aain ( fx, x  :  operand_type ) ; 

function_acoa ( f x, x  :  operand_type) ; 

function_atan<fx,x  :  operand_type); 

generate_reciprocal(fx,x  :  operand_type) ; 
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File:  LIB. PAS 
module  lib; 

$indude  (emu_lib.def) 

$include  (lib. def) 

$ include (global . def) 

$include (exprsion.def) 

$ include (exprtree . def) 

$include (utility. def) 

$ include ( fetch_tk .def) 

$ include ( symbol_t . def) 

$include (code_gen.def ) 

^include (declare . def) 

private  lib; 

procedure  function_tuunc(var  fx  :  operand_type;x:operand_type) ; 
begin 

write_error ( 'only  rounding  mode  is  supported  :  * ,fx.id); 

end;  (  of  function_trune  ) 

procedure  function_round (var  fx  ;  operand_type;x:operand_type) ; 
begin 

generate  ALU_operation (fx, x, zero_operand, unary^round) ; 
genera te_ALU_oper at ion  ( fx,  fx,  zero_operand,  unary_float) ; 
fx.id_type  integer_symbol_type; 
end;  (  of  function_round  ) 

procedure  generate_gt_f  fs  (function__number  :  integer;  f,  r,  s  :  operand_type)  ; 

{  This  procedure  produces  code  that  is  needed  to  lookup  a  function  value  from 
the  GT-FFS/1  function  board.  } 

var  negative_one  :  operand_type ;  (  is  used  to  assign  r  operand  to  a  negative  number  } 
w,  m  ;  longint;  {  are  used  to  store  the  values  of  write_opcode  and  msvr  } 
begin 

if  write_lookahead_buffer [1] .id  <>  blank_token  then  generate_nop; 
if  write_lookahead_buffer(0] .id  <>  blank_token  then 
if  (write_lookahead_buffer [0] .id  -  r.id)  and 

(write_lookahead_buf f er [ 0 1 . index  -  r. index)  and 
(write_lookahead_buf fer [0] .offset  -  r. offset)  then 
generate__nop 
else 

if  (write_lookahead_buffer (0] -id  -  s.id)  and 

(write  lookahead_buf fer [0] . index  -  s. index)  and 
(write_lookahead_buffer (0] .offset  -  s. off set)  then 
generate_nop; 

write  (out file, ’ ;  ’); 

operand_string  (f ,  temp_token) ;  <, 

write_token  (outfile,  temp_token) ; 

write  (outfile,'  :-GT_FFS(',  function_number, * , ' ) ; 
operand_string (r,  temp_token) ; 

write_token  (outfile,  t.emp_token) ;  write  (outfile,  ’,*); 
operand_string (s,  temp_token) ; 
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write_token  (out file, terap_token) ;  writeln( out file, ' ) * ) ; 

assign_real_constant (negative_one, -1.0); 
case  function_number  of 

1  :  begin 

w  4; 

ra  0; 

r  zero_operand; 

end; 

2  :  begin 

w  4; 

ra  Is 

r  zero_operand; 

end; 

3  s  begin 

w  4; 

ra  1; 

r  s-  negative_one; 
end; 

4  :  begin 

v  5; 

ra  0; 

r  zero__operand; 

end; 

5  :  begin 

v  5? 

ra  s-  0; 

r  negative_one; 

end; 

6  :  begin 

w  5; 

ra  1; 

end; 

7  ;  begin 

w  4; 

m  0; 

r  negative_one; 

end; 

8  :  begin 

w  7; 

m  ;»  0; 
end; 

9  ;  begin 

w  6; 

raj-1; 

r  zero_operand; 

end; 

10:  begin 

w  6; 

m  0; 


end; 


end;  {  of  case  function_number  of  > 

find  symbol (r. id, r.id_type, r.id_address, found) ;  if  not  found  then 
write_error(* unknown  id: 

r .  index_address  assign__index (r. index) ; 

find_syrabol ( s. id, s.id_type, s.id_address, found) ;  if  not  found  then 
write_error  ( ’  unknown  id : 

s .  index_addres  s  assign_index (s. index) ; 

find  symbol(f .id, f.id_type,f. id_addr ess, found) ;  if  not  found  then 
write_error { ’ unknown  id: 

f . index_addr es s  assign_index (f. index) ; 

microcode_address  prograra_counter; 

AR  r.id_address  +  r. offset; 

if  (r. index  <>  blank_token)  and  ( r. index [1]  <>  *0')  and 

<r.id[l]  <>  ’*’)  and  {r.id(l]  <>  **’)  then 


AIR [ 0 ]  r.index_address; 


AS  s.id_address  +  s. off set; 

if  {s. index  <>  blank_token)  and  <s.index(l]  <>  '0*1  and 
<s.id[l]  <>  *4*)  and  {s.id[l]  <>  **’)  then 
begin 

AIS[0]  s.index_address; 


output_micr ocode_f ield ; 
program_counter  prograra_counter+l; 
microcode_address  progr am_count er ; 

AF{0]  f.id_address  ■*  f. offset; 

if  (F. index  <>  blank_token)  and  (F.indextll  <>  *0’)  and 
(F.idJlJ  <>  ’4')  and  (F.idfl]  <>  ’*’)  then 


AIF [0]  f . index_address; 

IA2[01  1; 


write_opcode  w; 
if  function_number  -  7  then 

{  allows  branches  to  be  controlled  by  the  calling  procedure  function_tan . 
If  the  branch  address  is  not  altered  by  the  calling  procedure,  the  code 
will  simply  move  to  the  next  program  location  } 
begin 

AM2  9 1 0_opcode  CJP; 

branch__opcode  if_negative; 

branch_address  :  —  program_counter+l; 
end; 


output_microcode_field; 
program_counter  prograra_counter+l; 
end;  {  of  generate_gt_ff s  } 


procedure  generate_reciprocal (fx, x  ;  operand_type) ; 
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const  iteration  -  1; 

var  FI, F2, two  :  operand^ type; 

i  :  longint; 
begin 

operand_string  { f x,  temp_token) ; 
write (outfile, *;  begin  {  *); 
write_token  (out file,  temp_token)  s 
write (outfile, *  1/'); 

operand_string(x,  temp_token) ; 
write_token (outfile, temp_token) ; 
writeln (outfile, * )  }'); 

generate_gt_ffs(4, fx,x,x) ;  {  fx  :-F4(x,x)  } 

(  Kewton  Raphson's  iteration  ) 

for  i  1  to  iteration  do  (  fx  fx*(2-fx*x)  J 

begin 

writeln(outfile, * ;  Newton  Raphson  iteration  '  ,i); 
reset_operand (FI ) ; 

assign_temp_parameter  (FI,  real_symbol_type) ; 

generate_ALU_operation (FI, fx, x, multiplication) ;  {  FI  fx  *  x  } 

assign_real_constant (two. 2. 0) ; 
assign_temp_j?arameter  (F2, real_symbol_type) ; 

generate_ALU_operation (F2, two, FI, subtraction) ;  (  F2  2.0  -  FI  } 

fx.id_type  real_syrabol_type; 

generate_AliU_ operation  (fx,  fx,F2, multiplication) ;  {  fx  fx  *  F2  ) 
end;  {  of  i  1  to  iteration  } 
operand_string(fx,  temp_token) ; 
write (outfile, ' ;  end  {  *); 
writ e_token (outfile,  terap_token) ; 
write (outfile, • 

oper  and__s  t  ring  ( x ,  temp_token)  ; 
write_token (outfile, temp^token) ; 
writeln ( outfile , * )  ) * ) ; 
end;  (  of  generate_reciprocal  ) 

procedure  function_exp(fx,x  :  operand_type) ; 
var  k,invln2,ln2,r  :  operand__type; 

Z,W, pl,p2,p3,half. two  ;  operand_type; 
begin 

operand_string (fx,  temp_token) ; 
write (out file, * ;  begin  {  *); 
write_token (outfile,  temp_token) ; 
write (outfile, *  j-exp('); 
operand_string(x,  temp_token) ; 
write_token (outfile, temp^token) ; 
writeln (outfile, * )  )'); 

writeln (outfile, * ;  (  calculate  k  round (x/ln(2) )  )*); 

assign_temp_parameter (k, real_symbol_type) ; 
assign_real__constant  (invln2, 1.0/ln{2.0) ) ; 

generate_ALU_operation (k,x,invln2, multiplication) ;  {  k  x  /  ln(2)  ) 
generate_ALU_operation (k, k, zero_operand, unary_round) ;  {  k  round (k)  } 
writeln (outfile, * ;  {  calculate  the  remainder  r  :«  x  -  float(k)*ln2  )’); 
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ass ignjrea l_con st ant (ln2 , In (2) ) ; 
assign_terep_pararaeter  (r,  real_syrabol_type) ; 

generate__ALU_operation(r,  k,  zero_operand,  unary_float)  ;  {  r  float  (k)  } 
generate_ALU_operation(r, r,ln2, multiplication) ;  (  r  r*ln2  } 
genera te_ALU_ope ration (r,x,r, subtraction) ;  (  r  x  -  r  ) 

{  assign  pl,p2,p3  } 

assign_real_constant (pi, 4 . 9987178778e-2) ; 
assign  real_constant (p2, 4. 1602886268e~3) ; 
assign_real_constant (p3, 2 . 4999999950e-l ) ; 
writeln (outfile, ’ :  {  calculate  z  r*r  } ' ) s 

assign_ temp_pararaeter  (z,  real_symbol_type) ; 
generate  ALU_operation (z,r,r, multiplication) ;  {  z  :•  r*r  ) 
writeln (outfile, {  calculate  w  r*(z*p2+p3)  }'); 
assign^tempjparameter  (w,  real_symbol_type)  ? 

generate_ALU_operation(w, z,p2, multiplication) ;  {  w  z*p2  } 
genera te_ALU_oper at ion (w,  w,  p3 , addition) ;  {  w  w+p3  } 
generate_ALU_operation (w, r , w, multiplication) ;  {  w  r*w  } 
writeln (outfile, ' ;  {  calculate  fx(r)  -  O.S  +  w/ (0.5+z*pl-w)  }*); 

assign_real_constant (half, 0.5) ; 

generate_ALU_operation (fx,z, pi. multiplication) ;  {  fx  z*pl  ) 
generate_ALtJ_operation (fx, half,  fx,  addition) ;  {  fx  0.5+fx  ) 

generate_ALU_operation(fx, fx,w, subtraction) ;  (  fx  s-  fx-w  ) 

generate_reciprocal (z, fx) :  {  z  1/fx  ,  z  is  used  as  temporary  variable  } 
generate_ALU_operation(fx,w, z, multiplication) ;  (  fx  w*z  ) 

generateJU,U_operation  (fx,  half,  fx,  addition) ;  (  fx  0.5  +  fx  ) 

writeln (outfile, *;  {  calculate  fx  FI  (k)  *fx(r)  *2  D ; 

generate_gt_f fs (1, k,  k,  k) ;  {  k  :•  Fl(k,  k)  ) 

generate_ALU— operation (fx, k, fx, multiplication) ;  {  fx  k*fx  ) 
assign_real_constant (two, 2 . 0) ; 

generate_ALU_operation(fx, fx, two, multiplication) ;  (  fx  fx*2  ) 
operand_string(fx,  temp_token) ; 
write (outfile, ’ ;  end  {  *): 
write_token (outfile,  temp_token) ; 
write (outfile, '  exp ( ’ ) ; 
operand_string(x,  temp_token) ; 
write_token  (outfile,  temp__token) ; 
writeln (outfile, ’)  }T); 
end;  {  of  function^exp  ) 

Procedure  function_ln(fx,x  :  operand_type) ; 

var  one,ln2,r,p, al,a2,a3,a4,a5,a6,a7,a8  :  operand_type; 

begin 

operand_string ( fx,  temp_token) ; 
write (outfile, * ;  begin  {  *)? 
write_token (outfile,  temp_token) ; 
write (outfile, *  ln('); 

operand_string  (x,  temp_token) ; 
write_token  (outfile,  temp__token) ; 
writeln (outfile, ’)  }'): 

writeln (outfile, * ?  {  calculate  fx  ;*  F2(x)*ln2  £  r  F3(x)-1  }  ’); 

assign_real_constant (ln2.  In (2) ) ; 


a»sign_real_constant (one, 1.0); 
assign_temp_parameter (r,  real_syrabol_type) ; 
generate_gt_f fa (2, fx, x, x) ;  (  fx  F2 (x)  ) 

<*  generate_ALU_operation (fx, fx, zero_operand, unary_float) ;  temporary  fixes  for  the  EPROM. 
The  EPROM  should  have  returned  a  real  number.  *) 
generate_gt_ffa (3, r,x,x) ;  {  r  F3 (x)  } 

generate_ALU_operation(fx, fx,ln2, multiplication) ;  (  fx  fx*ln2  ) 
generate_ALU_operation (r,r, one, subtraction) ;  {  r  r-1  ) 

writeln(outfile, * ;  (  calculate  p  r (al+r(a2+r (a3+r (a4+r (a5+r (a6+r (a7+r{a8) )))))) )  }*) 

asaign_real_constant (al ,  0 . 9999964239) ; 

assign_real_constant (a2, -0.4998741238) ; 

assign_real_constant (a3,  0.3317990358); 

asaign_jreal_constant (a4, -0.2407338084) ; 

assign_real_constant (a5,  0.1676540711) ; 

a  ssign_r ea l_const  ant (a6, -0 . 0953293897 ) ; 

assign_real_constant (a7,  0.0360884937); 

assign_real_ constant (a8, -0 . 0064535442) ; 

assign_tempjparameter (p, real_syrabol_type) ; 

generate_ALU_operation(p,a8, ^multiplication) ;  {  p  a8*r  } 
generate_Am_operation<p.a7,p,  addition)  ;  {  p  a7+p  ) 
generate_ALU_operation (p,r,p, multiplication) ;  {  p  ;■»  r*p  ) 
generate_ALU_operation<p,a6,p, addition)  ;  {  p  a6+p  } 
generate_ALU_operation (p,r,p, multiplication) ;  (  p  r*p  } 
generate_ALU_operation (p, a5,p, addition)  ;  (  p  s-  a5+p  } 
generate__ALU_operation  (p,  r,  p, multiplication ) ;  (  p  s-  r*p  ) 
generate_ALU_operation(p,a4,p, addition)  ;  {  p  a4+p  ) 
generate_ALU_operation  (p,r,p, mult iplicat ion ) ;  {  p  r*p  } 
generate_ALU_operation(p,a3,p, addition)  ;  (  p  a3+p  ) 
generate_ALU_operation(p, r.p, multiplication) ;  (  p  r*p  ) 
generateALU operation (p,a2,p, addition)  ;  (  p  :■  a2+p  } 
generate^ ALU_operation(p, r.p, multiplication) ;  {  p  r*p  ) 
generate_ALU_operation(p,al,p, addition)  ;  {  p  al+p  ) 
generate_ALU_operation (p, r, p, multiplication) ;  (  p  r*p  ) 
writeln (outfile, * ;  (  calculate  fx  :«  fx  +  p  }'): 

generate_ALU_operation ( fx, fx, p, addition) ; 
operand_string  ( fx,  terap_token) ;  . 

write (out f ile, ' ;  end  (  ’); 
write_token(outfile,  terap_token) ; 
write (outfile, ’  In('); 

operand_string(x,  temp_token) ; 
write_token (out file, temp_token) ; 
writeln (outfile, ' )  ) 1 ) ; 

end;  (  of  function__ln  } 

procedure  function_sqrt  (fx,x  :  operand_type) ; 

const  iteration  -  1; 

var  FI, half , three  :  operand_type; 
i  :  longint; 

begin 

operand_string (fx,  temp_token) ; 
write (outfile, * ;  begin  (  '); 
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write_token (out file,  tercp_token)  ; 
write (outfile, *  sqrt(*); 
operand_string (x,  temp_token) ; 
write_token {outfile, terap_token) ; 
writeln (outfile, 1 )  } * ) ; 

generate_gt_f  fs  (5,  fx,  x,x) ;  (  fx  F5(x,x)  } 

-  aasign_temp_parameter (FI, real_syrabol_type) ; 
assign_real_constant (half ,  0, 5) ; 
assign_real_constant (three,  3.0); 

{  Newton  Raphson’s  iteration  } 

for  i  1  to  iteration  do  (  fx  0. 5*fx* (3-fx*fx*x)  ) 

begin 

writeln (outfile, Newton  Raphson  iteration  '  ,i); 

generate^ ALU_operation(Fl, fx, fx, multiplication) ;  {  FI  fx  *  fx  } 

generate_ALU_operation (FI, x, FI, multiplication) ;  {  Fl  x  *  Fl  } 

generate_ALU_operation(Fl, three, Fl, subtraction) ?  {  Fl  3  -  Fl  ) 

generate_ALU_operation(Fl, fx,Fl, multiplication) ;  {  Fl  fx*Fl  ) 
generate_ALU_operation(fx, half, Fl, multiplication) ?  {  fx  :«0.5*Fl  } 
end;  (  of  i  1  to  iteration  ) 

generate_ALU_operation(fx,x, fx, multiplication) ;  (  fx  fx*x  } 
oper and_str ing ( f x,  temp_token ) ; 
write (outfile, *;  end  {  *); 
write_token (outfile,  temp— token) : 
write (outfile, *  :-sqrt(f); 
operand_string(x,  temp^token) ; 
write_token (outfile, temp_token) ; 
writeln (outfile, * )  }f); 
end;  (  of  function_sqrt  > 

Procedure  function_sin (fx,x  :  oper and_t ype ) ; 

var  one,invpi,pil,k,r,z,p, al,a2,a3,a4  :  operand_type; 

begin 

operand_string  ( fx,  ternp_token) ; 
write (outfile, begin  {  '); 
write_token (outfile,  temp_token) ; 
write (outfile, *  sin(*); 

operand_string(x,  temp_token) ; 
write__token  (outfile,  temp_token)  ; 
writeln (outfile, * )  }'); 

writeln (outfile, *;  {  calculate  k  round(x/pi)  )’); 

assign_temp_parameter (k, real_symbol_type) ; 
assign_real_constant (invpi, 1/pi) ; 
assign_real_constant (pil,  pi) ; 

generate_ALU_operation  (k,x,  invpi,  multiplication) ;  {  k  x/pi  } 

generate_ALU_operation(k,k, zero_operand, unary _round) ;  {  k  round(k)  ) 

writeln (outfile, {  calculate  r  (x  -  float (k)*pi)  4  z  r*r  }'); 
assign_temp_parameter (r, real_symbol_type) ; 
a  s  s i gn_t  emp_par  amet e r (z, real_syrobol_type) ; 

generate_ALU_operation(r,k,zero_operand,unary_float) ;  {  r  :»  float (k)  } 

generate_ALU_operation (r,r, pil, multiplication) ;  {  r  r*pi  } 
generate_ALU_operation(r,x, r, subtraction) ;  (  r  ;  -  x-r  ) 
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generate_ALU_operation (z,r,r, multiplication) ;  {  z  r*r  } 

writeln (outfile, * ;  {  calculate  p  r (1+z (al+z (a2+z (a3+z (a4) ) ) ) )  }’); 

assign^ temp_j>araraeter  (p,  real_syrabol_type) ; 

assign__real_constant  (al,-l ,  666665668e-l)  ; 

as»ign_real_constant (a2,  8 .333025139e-3) ; 

assign_real_constant (a3,-l. 980741872e-4) ; 

as»ign_real_constant (a4,  2.€01903036e-6) ; 

assign_real_constant(one,1.0) ; 

generate_ALU_operation(p,a4, z, multiplication) ;  {  p  a4*z  ) 
generate_ALU_operation(p, a3,p, addition)  ;  (  p  a3+p  } 
generate_ALU_operation (p, zfp, multiplication ) ;  {  p  z*p  } 
generate_ALU_operation(p,a2,p, addition)  ?  {  p  a2+p  ) 
generate_ALU_operation(p, z,p, multiplication ) ;  {  p  z*p  ) 
generate_ALU_operation(p,al,p, addition)  ;  ip;-  al+p  } 
generate_ALU_operation{p, z,p, multiplication) ;  {  p  z*p  ) 
generate_ALU_operation(p, one, p, addition)  ;  {  p  1+p  ) 
-generate_ALU_operation(p, r,p, multiplication) ;  {  p  r*p  } 
generate_GT_FFS(6,fx,k,p);  {  fx  F6(k,p);  } 
operand_3tring  ( fx,  temp_token) ; 
write (outfile, *;  end  {  f); 
write_to)cen(outfile,  terap_token) ; 
write ( out f ile, *  sin('); 

operand_string(x,  temp_token> ; 
write_j token (outfile, temp_token) ; 
writeln (out file, ’ )  ) * ) ; 

end;  {  of  function_sin  ) 

Procedure  function__coa  (fx,x  :  operandtype)  ; 

var  one,invpi,piov2,pil,k,r,z,xl,p,al,a2,a3,a4  :  operand_type; 

begin 

operand_string(fx,  terop_token) ; 
write ( out f ile, ' ;  begitn  {  *); 
write_token (outfile,  terap_token) ; 
write (outfile, '  cos(')/ 

operand_string(x,  temp_token) ? 
write_token (outfile, terop_token) ; 
writeln (outfile, ' )  } ’ ) ; 

writeln (outfile, ’ ;  (  calculate  xl  x+pi/2  )’); 

assign_temp_parameter (xl, real_3ymbol_type) ; 
a*sign__rea Inconstant  (invpi,  1/pi)  ; 
assign_real_constant (piov2, pi/2) ; 
generate_ALU_operation (xl, x, piov2 , addition) ; 
writeln (outfile, {  calculate  k  round(xl/pi)  ) * ) ; 
as3ign_temp_parameter (k,  real_symbol_type)  ; 
as8ign_realnConstant (pil,pi) ; 

generatenALU_operation(k,xl, invpi, multiplication) ;  {  k  xl/pi  ) 

generate_ALU_operation(k, zero_operand,unary_round) ;  (  k  round (k)  ) 
writeln (out f ile, (  calculate  r  (xl  -  float(k)*pi)  }'); 
assign_temp_parameter (r, real_symbol_type) ; 
assign_temp_parameter (z, real_symbol_type) ; 

generate_ALU_operation(r, k, zero_operand, unary_f loat ) ;  (  r  float(k)  ) 
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generate_ALU_operation(r, r,pil, multiplication) ;  {  r  s-  r*pi  ) 

generate__ALU_operation(r,xl,r,  subtraction)  ;  (  r  :  -  xl-r  ) 

generate_ALtf_operation(z,r, ^multiplication) ;  {  z  r*r  ) 

writeln (outfile, ' ;  (  calculate  p  r <l+z (al+z (a2+z (a3+z (a4) ) ) ) )  )*)* 

aasign_tempjparameter  (p,  real_symbol_type) ; 

a ss ign^rea Inconstant  Cal, -1 , 666665668e-l) : 

aasign_real_constant (a2,  8 .333025139e-3) ; 

assign_real_constant (a3, -1 . 980741872e-4) ; 

asaign_real_constant  (a4,  2. 60190303 6e-6) ; 

assign_real_constant(one,l.Q) ; 

generate_ALU_operation(p,a4, z, multiplication) ;  {  p  a4*z  ) 

generate_ALU_operation (p, a3 ,  p, addition)  ,*  {  p  a3+p  ) 
generate_ALU_operation(p,z,p, multiplication) ;  (  p  z*p  ) 

generate_ALU_operation(p,a2,p, addition)  ;  {  p  s-  a2+p  ) 

generate_ALU_operation(p, z,p, multiplication) ;  (  p  z*p  ) 
generate_ALU_operation(p,al,p,  addition)  ;  1  p  al+p  ) 

generate_ALU_ope ration (p, z, p, multiplication) ;  {  p  z*p  ) 
generate_ALU_operation(p, one, p, addition)  ;  {  p  1+p  ) 

generate_ALU_operation Cp,r,p, multiplication) :  {  p  r*p  } 
generate_GT_FFS(6,fx,k,p);  {  fx  F6(k,p>;  ) 
operand_string(fx,  terap_token) ; 
write Coutfile, *;  end  {  *  )J 
write_token(  out  file,  temp_to)cen)  ; 
write (outfile,  *  :-cos(’); 
operand_string (x,  temp^token); 
write_token  (out  file,  temp__token) ; 
writelnC outfile, *)  }'); 

end;  (  of  function_cos  } 

Procedure  function_tan(fx,x  :  operand_type) ; 

var  one, invpiov2, piov2, k, t, r, z,xl,p, q,pl,q2,ql  :  operand_type; 

povq_address  ;  longint;  {  starting  address  for  the  evaluation  of  p/q  ) 
qovp_address  :  longint;  {  starting  address  for  the  evaluation  of  q/p  ) 

begin 

operand_string ( fx,  temp_token) ; 
write (outfile, *;  begin  {  '); 
write_token (outfile,  temp_token) • 
write (outfile, *  :-tan('): 
operand_string (x,  temp_token) ; 
write^to ken  (out file,  terap_token)  ,* 
writeln (outfile,  *)  )M; 

writeln (outfile, *:  {  calculate  k  round (x*4/pi)  )’); 

assign_temp_pararaeter (k, real_symbol_type) ; 
assign__real— constant  (piov2,pi/2) ; 
assign_real_constant (invpiov2, 2 /pi) ; 

generate_ALU_operation(k,x,invpiov2, multiplication) ;  {  k  x*4/pi  } 

generate_ALU— operation (k, k, zero_operand, unary _round) ;  (  k  round (k)  } 
writeln  (outfile,  *  ,*  {  calculate  r  (x  -  float  (k)  *pi/4)  } ' ) ; 

assign_temp_parameter (r,  real_symbol_type) ; 

generate_ALU_operation(r, k, zero_operand, unary_float) ;  (  r  float (k)  } 

generate_ALU_operation (r, r,piov2, multiplication) ;  (  r  r*pi/4  ) 
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generate_AI*U_operation(r,x, r, subtraction) ;  {  r  :  -  x-r  } 
vriteln {outfile, * ;  {  calculate  z  s-  r*r  }’)* 

assign_temp_parameter (z, real_aymbol_type) ; 
generate_ALtf_operation (z,r, ^multiplication) ;  (  z  :■*  r*r  } 
vrlteln (out file. * ;  i  calculate  q  (1.0  +  (q2*z  +  ql)*z)*); 

asslgn_real_conatant (q2, 9.71685835e-3) ; 
aasign_real_constant (ql,-4.29135777e-l) ; 
assign_real_conatant (one, 1.0) ; 
assign_terapjpararaeter  (q,  real^syrabol^type) ; 
generate_ALU_operation(q,q2, z, multiplication) ;  {  q  :•  q2*z  ) 
generate_ALU_operation(q,q, ql, addition) ;  (  q  s-  q  +  ql  .) 
generate_ALU_ operation (q, q, z, multiplication) ;  {  q  q*z  } 
generate_ALU_operation (q, one, q, addition) ;  {  q  1.0  +  q  ) 
vriteln(outfile, :  calculate  p  (pl*z*r  +  r)'); 
asaign_temp_parameter (p, real_symbol_type) ; 
assign_real_constant (pi, -9. 58017723e-2) ; 

generate_ALU_operation(p, pi, z, multiplication) ;  {  p  pl*z  ) 

generate_ALU_operation(p,p, r, multiplication) ;  {  p  p*r  ) 

generate_ALU_ operation (p, p, r. addition) ;  {  p  p  +  r  1 

writeln (outfile, ’ ;  {  if  k  is  even  then  fx  p/q  else  fx  q/p  )'); 

assign_temp_pararaeter (t, real_symbol_type) ; 

generate_gt_ffs (7, t, k, k) ;  (  t  F7(k)  } 

writeln {outfile, {  calculate  fx  p/q  >*); 

povq_address  :*  program__counter; 

generate_reciprocal(fx,  q) ;  {  fx  1/q  ) 

generate_ALtJ_operation(fx,p,  fx, multiplication) ;  (  fx  p*fx  } 
generate_Nop; 

microcode_address  prograra_counter; 

am2910_opcode  CJP; 

branch_opcode  unconditional; 

writeln (outfile, ' ; 30:  unconditional  branch  '); 

output_microcode_field; 

program_counter  prograra_counter  +  1; 

writeln (outfile, {  calculate  fx  q/p  )•); 

writeln (out file, 'b  * ,povq_addr e as- 1, ’  * , program_counter) ; 

qovp_address  prograra_counter ; 

generate_reciprocal (fx, p) ;  {  fx  1/p  } 

generate_ALU_operation(fx,q, fx, multiplication) ;  (  fx  q*fx  ) 

generate_Nop; 

generate_Nop; 

vriteln (outfile, 'b  * , qovp_address-*l, '  *,program_counter); 
writeln (outfile, fx  F8 (LF7,x, fx) * ) ; 
generate_gt_ffs(6, fx, k, fx) ; 
operand_atring (fx,  temp_token) ; 
write (outfile, ' ;  end  {  •); 
write_token (out file,  temp_token) ? 
write (outfile, '  :-tan(’)? 
operand_string (x,  temp_token) ; 
wr ite_token ( outfile , temp_t o  ken ) ; 
writeln (outfile, ? )  )’): 
end;  (  of  function_tan  } 
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Procedure  function^  sin  (fx,x  :  operand_type) ; 

var  piov2, one, t, r,p»  sqrtl_r,aO, al, a2,  a3, a4, a5, a6,  a7  :  operand_type? 

begin 

operand__string(fx,  temp_token) ; 

write (outfile, * ;  begin  C  '); 

write_token (out file,  temp_token) ; 

write (outfile, *  asin(’); 

operand_»tring (x,  temp_token ) ; 

write_token (outfile, terap_token) ; 

writeln (out file, ' )  }*); 

writeln (outfile, ' ;  r  l x |  '); 

as signet emp_parame ter  (r,  real_syinbol_type)  ; 

generate  gt_ffs <9, r, zero_operand,x) ;  {  r  abs(x)  if  -1  <-  x  <-  1  else  r  -  NAN  } 

writeln (outfile, {  calculate  p  pi/2  -  sqrt  (1-r)  (aO+r  (al+r  (a2+r  (a3+r  (a4+r  (a5+r  (a6+r  (a7) )))))) )  D; 

assign_temp_parameter (p, real_symbol_type) ; 

assign_temp_parameter (sqrtl_r, real_syrabol_type) ; 

assign_temp_pararaeter (t, real_symbol_type) ; 

assign_real_constant (aO,  1. S707963050) : 

assign_real_constant (al,-0 .2145988016) ; 

assignor eal_const ant (a2,  0.0889789874); 

assign^ real_constant (a3, -0.0501743046) ; 

assign_real_constant (a4,  0.0308918810) ; 

assign_real_constant (a5,-0 .0170881256) ; 

assign_real_constant (a6,  0 . 0066700901) ; 

assign_real_constant (a7, -0.0012624911) ; 

assign_real_constant (piov2, pi/2) ; 

assign_real_constant (one, 1.0); 

generate_ALU_operation (t, one, r , subtraction) ; 

function^ qrt  (sqrtl_r,  t) ; 

gener at e_ALU_oper a t ion (p,r, a 7, multiplication)  ;  ip:-  r*a7  ) 
generate_ALU_operation(p, a 6, p, addition)  ;  (  r  a6+p  ) 

generate_ALU_operation (p,r,p, multiplication) ;  {  p  r*p  ) 

generate_ALU_operation(p,a5,p, addition)  ;  {  r  a5+p  ) 
generate_ALU_operation (p, r,p, multiplication) ;  (  p  r*p  ) 
generate_ALU_operation(p,a4,p, addition)  ;  (  r  a4+p  ) 
generate_ALU_operation (p,r,p, multiplication) ;  {  p  :«  r*p  } 
generate_ALU_operation(p,a3,p, addition)  ,*  l  r  a3+p  ) 
generate_ALU_operation (p, r , p, multiplication) ;  (  p  r*p  } 
generate_ALU_operation(p, a2, p, addition)  ;  {  r  a2+p  ) 

generate_ALU_operation<p,r,p, multiplication);  {  p  r*p  } 
generate_ALU_operation(p,al,p, addition)  ;  (  r  :»  al+p  } 
generate_ALU_operation (p,r,p, multiplication) ;  {  p  r*p  ) 

generate_ALU_operation(p,aO,p, addition)  ;  (  r  s-  aO+p  ) 

generate_ALU_operation(p, sqrtl_r.p, multiplication) ;  (  p  sqrtl_r*p  } 
generate_ALU_operation(p,piov2,p, subtraction) ;  (  p  pi/2  -  p  } 
writeln  (out  file,  * ;  (  fx  design  (x) )  *p  }'); 

generate_GT_FFS (10, fx,x,p) ;  (  fx  :-F10(x,p);  ) 

operand_string ( fx,  temp_token) ; 
write (outfile, * ;  end  {  '); 
write_token (outfile,  temp_token) : 


write (out file, •  s-  asin ( ' ) ; 
operand_string (x,  temp_token) ; 
write__token  (outfile,  terap_token) ; 
writeln (outfile, *)  }'); 

end;  (  of  function_asin  } 

Procedure  function_acos (fx,x  :  operand_type) ; 

var  piov2,one,t,r,p,sqrtl_r,a0,al#a2,a3,a4,a5,a6,a7  :  operand_type; 

begin 

operand_string ( fx,  temp_token) ; 
write ( out f ile, ' ;  begin  (  •); 
write_token (outfile,  teinp_token) ; 
write (outfile, '  acos('); 
operand_string(x,  terap_token) ; 
write_token (outfile, temp_token) ; 
writeln (outfile, * )  ) * ) ; 
writeln (outfile, *;  r  |x|  *); 
assign_terap_parameter  (r,  real_symbol_type) ; 

generate_gt_ffs (9, r, zero_ operand, x) ;  (  r  :»  abs(x)  if  -1  <-  x  <-  1  else  r  -  NAN  } 

writeln (outfile, *;  (  calculate  p  pi/2  -  sqrt (1-r) (aO+r (al+r (a2+r (a3+r(a4+r (a5+r <a6+r (a7) )))))) )  )») 

assign_temp_parameter (p, real_symbol_type) ;  > 

assign_temp_pararaeter  (sqrtl_r, real_symbol_type) ; 

aasign_terap_parameter (t , real_symbol_type ) ; 

assign_real_constant (aO,  1.5707963050) ; 

assign_jreal_constant  (al,-0 .2145988016)  ? 

assign_real_constant (a2,  0 . 0889789874) ; 

assign^ real_constant (a3, -0.0501743046) ; 

assign_real_constant (a4 ,  0.0308918810) ; 

assign_real_constant (a5, -0 . 0170881256) ; 

assign_real_constant (a6,  0.0066700901) ; 

assign_real_constant (a7, -0 . 0012624911) ; 

assign_real_constant (piov2,  pi/2) ; 

assign_real__constant (one, 1.0); 

generate_ALU_operation (t, one, r, subtraction) ; 

function_sqrt (sqrtl_r, t) ; 

generate_ALU_operation(p,r,a7, multiplication)  ;  {  p  r*a7  ) 
generate_ALU_operation(p,a6,p, addition)  ;  {  r  a6+p  ) 
generate_ALU_operation (p,r,p, multiplication) ;  {  p  r*p  ) 
generate_ALU__operation(p, a5, p, addition)  ;  (  r  aS+p  ) 
generate_ALU_operation(p, r,p, multiplication) ;  {  p  r*p  ) 
generate_ALU_operation(p,a4,p, addition)  ;  (  r  s-  a4+p  } 
generate_ALU_operation(p,  r,p, multiplication) ;  (  p  :«•  r*p  ) 
generate_AXiU__operation(p,a3,p, addition)  ;  {  r  a3+p  } 
generate_ALU_operation(p, r,p, multiplication) ;  {  p  r*p  ) 
generate_ALU_operation (p, a2, p, addition)  ;  {  r  a2+p  ) 
generate_ALU_operation(p, r,p, multiplication) ;  {  p  r*p  ) 
generate_ALU_operation (p, al, p, addition)  ;  {  r  al+p  ) 
generate_ALU_operation(p, r,p, multiplication ) ;  {  p  r*p  ) 
generate_ALU_operation(p,aO,p, addition)  ;  {  r  aO+p  ) 
generate_ALU_operation (p, sqrt l_r,p, multiplication) ;  {  p  sqrtl_r*p  ) 
generate_ALU_operation(p,piov2,p, subtraction) ;  {  p  s-  pi/2  -  p  } 


Digital  Emulation  Technology  Laboratory  Final  Repeal 


183 


writeln (outfile, * ;  {  fx  design (x) )*p  )*); 

generate_GT_FFS (10, fx, x,p) ;  {  fx  :-F10(x,p);  ) 

generate_ALU_operation (fx, piov2, fx, subtraction) ; 
operand_string  ( fx,  terap_token) ; 
write (outfile, ’ :  end  (  *); 
write_token( out file,  temp_token) ; 
write (outfile, *  acosf); 
operand_string (x,  terap_token) ; 
write_token (outfile, temp_token) ; 
writeln (outfile, ')  )'); 
end;  {  of  function_acos  } 

Procedure  function_atan(fx, x  :  operand_type) ; 

var  one, t,r,p, z, al,a2, a3,  a4,  a5,a€,a7,  a8,piov2,ntpiov2  i  operand_type; 

start_address, addressl, address2  :  longint; 
begin 

operand_string ( f x,  temp_token) ; 
write (outfile, *;  begin  {  *); 
write^token (out  file ,  terap_token ) ; 
write (outfile, *  :■  atan(’); 
operand_string(x,  terap_token) ; 
write_token (outfile, temp_token) ; 
writeln (outfile, •)  }'): 

writeln (outfile, (  r  -  x  if  (-1  <-  x  <-  1)  else  r  -  1/x  D; 
aasign_real_constant (one, 1.0); 
a*sign_temp_parameter  (r,  real__symbol^type)  ; 
assign_terap_pararaeter (t, real_symbol_type) ; 
branch__lookahead_buf  fer  (2  ]  if_negative; 

generate  ALU_operation(t, one, x, subtraction) ;  {  if  x  >  1  then  branch  to  evaluate  1/x  } 
start_address  program_counter-l; 
branchy lookaheadjouffer [2]  if_negative; 

generate_ALU_operation(t, x, one, addition) ;  {  if  x  <  -1  then  branch  to  evaluate  1/x  } 
addressl  i-  prograra_counter-l; 
branch_lookahead_buf fer [2]  unconditional; 

gene rate_ALU_operat ion  (r ,  x,  zero_operand,  addition) ;  {  r  x  } 

address2  program_counter-l; 

clear_pipeline_stage; 

writeln (outfile, ‘b  • , start_addre33+2, '  ’ ,program_counter) ; 
writeln (outfile,  *b  ’ ,addressl+2, f  * ,  program_counter) ; 
writeln  (outfile, 1 ;  {  calculate  r  1/x  }'),* 

generate_reciprocal(r,x) ;  (  r  1/x  ) 
clear_pfpeline_3tage; 

writeln (outfile, 'b  • , address2+2, •  * ,prograra_counter) ; 

writeln (out file. {  calculate  fx  r (al+z (a2+z <a3+z <a4+z (a5+z (a6+z (a7+z (a8) )))))) )  )'); 

assign__temp__parameter  (z, real_symbol_type)  ; 

a  s  s i gn_t erap_pa  r arae t  e  r (p, real_symbol_type) ; 

assign_real_constant (al,  0.9999993329); 

assign_real_constant (a2, -0.3332985605) ; 

assign_real_constant (a3,  0.1994653599) ; 

assign_real_constant (a4, -0 . 1390853351) ; 

assign_real_constant (a5,  0 . 0964200441) ; 
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assign_real_constant (a6, -0. 0559098861) ; 
aasign_real_constant (a7,  0.0218612288); 
assign_real_constant (a8, -0 . 0040540580) ; 

generate_ALU_operation(z, r,r, multiplication) ;  {  z  r*r  ) 
generate_ALU_operation(p, z,a8, multiplication)  ;  {  p  z*a8  ) 
generate_ALU_operation(p,a7,p, addition)  ;  (  p  !-  a7+p  } 
generate_ALU_operation(p, z,p, multiplication) ;  {  p  z*p  ) 
generate^ ALU_ operation (p, a6, p, addition)  ;  {  r  a6+p  ) 
generate_ALU_operation (p,z,p, multiplication) ;  (  p  z*p  ) 
generate_ALU_operation(p,a5,p, addition)  ;  {  r  a5+p  ) 
generate_ALU-operation(p, z,p, multiplication) ;  {  p  :*»  z*p  } 
generate_ALU_operation (p, a4, p, addition)  ;  {  r  a4+p  ) 
generate_ALU_operation (p, z, p, multiplication) ;  {  p  s-  z*p  } 
generate_ALU_operation(p,a3,p, addition)  ;  (  r  a3+p  } 
generate_ALU_operation (p, z,p, multiplication) ;  {  p  z*p  } 
generate_ALU_operation(p,a2,p, addition)  ;  (  r  a2+p  ) 
gener at e_ALU_ope ration (p, z, p, multiplica tion) ;  {  p  z*p  ) 
generate_ALU_operation(p,al,p, addition)  ;  (  r  al+p  } 
generate_ALU_operation (fx,r,p, multiplication) ;  {  fx  r*p  ) 
start_address  program_counter; 
assign_real_constant (piov2,pi/2) ; 
branch_lookahead— buffer [2]  if_negative; 

generate^ALU^ operation (t,x, one. addition) ;  {  if  x  <  -1  then  branch 

to  evaluate  fx  s-  -  pi/2  -  fx  } 

branch_lookahead_buf f er [21  :*  i f_negative ; 

generate^ALU^operation (t, one, x, subtraction) ;  {  if  x  >  1  then  branch 

to  evaluate  fx  pi/2  -  fx  } 


generate__nop; 
genera  te__nop; 

raicrocode_address  prograra_counter ; 

AM2910_opcode  CJP; 

branch_opcode  unconditional; 

writeln (outfile, * : * , program_counter, ' ;  unconditional  branch' ) ; 

output_microcode_f ield ; 

prograra_counter  program_counter+l; 

clear_pipeline_st age ; 

addressl  program_counter; 

writ eln( out file, 'b  *,start_address+2, '  ' ,program_counter) ; 
writeln (outfile, * ;  {  calculate  fx  -  pi/2  -  fx  }’); 

branch_lookahead_burfer [2]  :•  unconditional; 
assign_real_constant (mpiov2, -1.5707963943) ; 

gener a te_ALU_ope ration (fx,mpiov2, fx, subtraction) ;  (  fx  -  pi/2  -  fx  ) 
clear_pipeline_stage; 

writeln  (out  file, 'b  ' ,  start_address+3,  '  ' , program_counter) ; 
writeln (outfile, * ;  (  calculate  fx  pi/2  -  fx  }*); 

generate_ALU_operation(fx,piov2, fx, subtraction) ;  {  fx  pi/2  -  fx) 
clear_pipeline_stage ; 

writeln (outfile, 'b  ' ,  start__address+4,  '  * , program_counter) ; 
writeln (outfile, 'b  * , addressl+2, '  ' , program_counter) ; 
operand_string(fx,  temp_token); 
write (outfile, ' ;  end  {  '); 
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vrite_token (outfile,  ternp_token) ; 
writ* (out file, *  :-atan(?); 
oper»nd_string(x,  temp_token) ; 
write_token {outfile, temp_token) : 
writeln (out file, * )  ) * ) ; 
end;  (  of  function_atan  } . 
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File:  MAINBODY . DBF 
public  ma inbody; 

Procedure  while_statement; 
Procedure  if_ statement; 
Procedure  for_stateraent; 
Procedure  compound^statement; 
Procedure  prograra_main_blocfc; 
Procedure  null  statement; 
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File:  MAINBODY . PAS 
module  raa inbody; 

$ include (global . def) 

$ include (utility . def ) 

$include (init . def) 

$ include ( fetch_tk . def) 

$ include (syrabol_t .def) 

$include (eode_gen . def) 

$include (exprsion.def) 

$include (exprtree . def) 

$include (declare . def) 

$include ( io . def) 

$ include (arith . def) 

$include (stdprocd.def ) 

$include (ma inbody .def) 

private  mainbody; 

$ include (if_while. pas) 

^include ( for_stat . pas ) 

$ include (procedur .pas) 

Procedure  null_statement; 
begin 

end?  {  of  null_statement  ) 

procedure  compound_stateraent; 
begin 

fetch_token; 

find_symbol (token, symbol_type, symbol_value, found) ; 

if  not  found  then 

begin 

writeln(errorfile) ; 

writeln(errorfile,  * ! !  I  error,  unknown  id:  token, ) ; 

error_found; 
end; 

if  token  -  begin_token  then 
begin 

corapound_sta tement ; 

while  token (l)-*;’  do  compound_statement; 
verify_token (token, end_token) ; 
fetch_token; 
end 
else 

if  token  -  while_token  then 
while_statement 
else 

if  token  -  repeat_token  then 
r epe  a t_s t at emen t 


else 
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if  token  -  if_token  then 
if^stateraent 
else 

if  token  -  for_token  then 
for_stateraent 
else 

if  (syrabol_type  -  procedure_9ymbol_type)  then 
procedure__call 
else 

if  (symbol_type  -  stands  rd_procedure_syjnbol_type)  then 
standard_procedure_bloek 

else 

if  ( symbol_type  -  real_symbol_type)  or 
(symbol_type  -  integer_syrnbol_type)  or 
(syrabol_type  -  boolean^symbol^type)  then 
begin 

if  syrabol_type  -  real_symbol_type  then 

constant_assignraent__type  real_constant_symbol_type 

else 

constant_a ssignraent_type  integersConstantsSymbol_type; 

assignment_statement ; 
end 
else 

if  ( syrabol_type  -  realsatray_symbol_type)  then 
begin 

constant_assignraent_type  real_array_symbol_type; 
index_as3ignntent__3tatement; 
end 
else 

if  (symbol_type  -  integersarray_sy7nbolstype)  then 
begin 

constant_assignrcent_type  integersarray_symbol_type; 

index_a3sigrunent_statement; 
end 
else 

if  (symbol_type  -  booleansarray_syinbolstype)  then 
begin 

const antsassignmentstype  boolean_array_symbol_type; 

index_assigrunent_stateraent; 
end; 

end;  {  of  compound_statement  } 

Procedure  prograitwnainjblock; 
var  start_address  :  longint; 
begin 

start_address  ;«  prograra_counter; 
branchslookaheadsbuffer [0]  ;*  unconditional; 
generate_nop; 

while  (  (token  -  var_declaration)  or  (token  -  const_declaration) 

or  (token  -  procedure_heading)  or  (token-function_heading)  )  do 


begin 
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if  (token-var_declaration)  then 
var_declaration_block 
else 

if  (token-const^ declaration)  then 
const_declaration_block 
else 

.if  (token-type__declaration)  then 
type_declaration_block 

else 

if  (token-procedure_heading)  then 
procedure_roain_block 

else 

if  ( token- function_heading)  then 
function_raain_block; 

end; 

if  (token-begin_token)  then 
begin 

writeln (outfile, ’b  * , start_address, '  * ,program_counter) ; 
compound_s ta t ement ; 

while  token (1  ;  f  do  compound^statement; 

end 

else 

begin 

writeln (error file) ; 

writeln (errorfile, MSI!  syntax  errror,  begin  expected*) 
error_found; 
end; 

verify__token  (token,  end_token) ; 
fetch_token; 

end;  {  of  program__mainj3lock  ) . 
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File:  MAKEFILE 

PASFLAGS  -  large  optimized)  symbolspace{64)  debug 
PLMFLAGS  -  large  optimized)  debug 


SOURCES  -  \ 

arith.pas  \ 
bit_func.plm  \ 
code_gen.pas  \ 
declare. pa s  \ 
erau_lib.pas  \ 
exprsion.pas  \ 
exprtree.pas  \ 
fetch_tfc.pas  \ 
global. pas  \ 
hex_conv.ps s  \ 
ieee_cnv.pas  \ 
init.pas  \ 
io.pas  \ 
lib. pas  \ 
raainbody.pas  \ 
stdprocd.pas  \ 
symbol_t.pas  \ 
utility. pas 

OBJECTS  -  \ 

arith.obj  \ 
bit_func.obj  \ 
code_gen . ob j  \ 
declare. obj  \ 
erau_lib.obj  \ 
exprsion.obj  \ 
exprtree.obj  \ 
fetch_tX.obj  \ 
global . obj  \ 
hex_conv . ob j  \ 
ieee_cnv . obj  \ 
init.obj  \ 
io.obj  \ 
lib. obj  \ 
mainbody.obj  \ 
stdprocd . obj  \ 
symbol_t.obj  \ 
utility. obj 


compiler:  compiler. obj  compiler. lib 

submit  :PFP:csd/PASbndl (  compiler,  'compiler .obj, compiler .lib' ,  debug  ) 


compiler .obj : 


compiler .PAS 


pas286  compiler. PAS  $(PASFLAGS) 

compiler .libs  $ (OBJECTS ) 

.PAS .obj : 

pas286  $<  $ (PASFLAGS) 

submit  :PFP : csd/lib (  compiler .lib,  $*  ) 


. PLM.obj : 

plra286  $<  $(PLHFLAGS) 

submit  :PFP: csd/lib (  compiler .lib,  $*  ) 


clean: 

delete  compiler, *.lst, *.obj, *.mp?, *.lib 
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Files  PLM_LIB.DEF  ' 
public  plra_help; 


procedure  plm_halt; 
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File:  PQCLOSE.DEF 
public  pqclose; 

procedure  pqclose (var  t 


:  text); 


Digital  Emulation  Technology  Laboratory  Final  Report 


194 


File:  PROCEDUR.PAS 
procedure  parameter_list; 
var  i#j  :  longint; 

index_nuraber  :  longint;  {  use  to  point  to  index  register  for  call  by  value  parameter  } 
var__type  :  longint;  {  use  to  store  the  type  of  the  parameter  } 

temp_dataram_address  :  longint;  {  use  to  store  temporarily  the  dataram  address  for  call  by  value  parameter  > 
pararaeter_type  :  longint; 
begin 

indexjnuraber  1; 
if  token  -  open_parenthesis  then 
begin 
repeat 
i  s-  0; 

fetch^token;  {  variable  name  /  var  ) 
if  token  -  var_declaration  then 
begin 

parameter_type  call_by_reference; 

fetch_token;  {  variable  name  } 
end 
else 

parameter_type  call_by_value; 

i  i+1; 

syrabol_array [i]  token;  {  insert  token  to  symbol  array  } 

fetch_token;  {  ,  ) 
while  token  -  comma  do 
begin 

feteh_ token;  (  variable_name  } ; 
i  i+1; 

syrabol_array [i]  token;  {  insert  token  to  symbol  array  > 

fetch_token; 
end; 

verify_token (token, colon) ; 
fetch_token;  (  variable_type  } 
if  (token  -  real_token)  then 
begin 

var_type  real_syrabol_type; 

end 
else 

if  (token  -  integer_token)  then 
begin 

var_type  integer_syrabol_type; 

end 
else 

if  (token  -  boolean_token)  then 
begin 

var_type  boolean_symbol_type; 

end 
else 
begin 

writeln (errorfile) ; 

writeln (errorfile, ' M !  error,  unsupported  parameter  type  :  token, ; 
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error_found; 

end; 

symbol^ type  va retype; 

for  j  1  to  i  do  {  insert  symbol_array  to  symbol  table  } 
begin 

new (new_parameter) ; 

new_parameter* . id  syrabol_array [ j] ; 

new^parameter^.id^type  : -  symbol_type; 
new__pararaeterA.parameter_type  parameter_type; 
new_pararaeter<' . next  nil; 

if  parameter_type  -  call_by_value  then 
begin 

insert_symbol (symbol_array { j J , symbol_type, symbol_value) ; 
new_pararaeter* .address  symbol_value: 

end 

else  {  call_by_reference  } 
begin 

insert_symbol (syrabol_array [ j] , symbol _type, symbol_value) ; 
new^parameter* . address  syrabol_value; 

end; 

if  procedure_linkA .pararaeter_link  -  nil  then 
begin 

procedure  JLink~.pararaeter_link  j-  new_parameter;  , 
end 
else 
begin 

current_pararaeter  procedure^ink*  .parameter_link; 

while  current_parameter* . next  <>  nil  do  currentjparameter  current_parameter*.next; 
current^ parameter^.next  :■  new__parameter; 
end; 

no_local— variable [procedure_level]  no_local_variable (procedure_level]+l; 

local_variable[procedure_level,no_local_variable[procedure_level] ]  symbol_array ( j J ; 

end; 

fetch_token; 

until  (  token  <>  semicolon) ; 
ver ify_token ( token , clo  se_par ent he  sis); 
fetch_token; 
end; 

end;  J  of  pa ramete r_list  } 

Procedure  procedure_main_block; 
var  i  :  longint; 

procedurejname  s  token_type; 
begin 

for  i  0  to  max_index_register  do  index_register [i]  blank_token; 
fetch_token;  {  procedure jname  } 
procedure_name  s*  token; 

writeln (out file, * ;  (  procedure  ' , procedure_name) ; 
symbol_type  procedure_syrabol_type; 
symbol_value  program_counter; 

insert_symbol  (procedure_name,  symbol_type,  symbol^value) 
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no_local_variable[procedure_level]  no_local_variable{procedure_level] +1; 

local_variable[procedure_level,no_local_variable [procedure_level] J  procedure_name; 
procedure__level  procedure_level+l; 
if  procedure_level  >  max_procedure_level  then 
begin 

writeln (errorfile) ; 

writeln (errorfile,  *!  I !  error,  maximum  procedure  nesting  level  exceeded,  max  -  ’ ,maxjprocedure_level) ; 
error_found; 
end; 

no_local_variable{procedure_level]  0; 

fetch_token: 

pararaeter_list ; 

{  find_symbol (procedure_narae, syrabol_type , symbol_value, found) ; 
current_parameter  procedure_link'‘ ,parameter_link; 
while  current_parameter  <>  nil  do 
begin 

writeln (outfile, ' - out  of  parameter  list - ’); 

writeln (outfile, ' cur r ent_parameter  id  :  * , current_parameter A . id) ; 

writeln (outf ile, 1 current_parameter  id_type  :  ' , current_parameter* . id_type) ; 
writeln (outfile, *  current  jparameter  address  :  ' ,current_parameterA.addres3) ; 
current_parameter  current_parameter'*.next; 
end;  ) 

verify_token (token, semicolon) : 
fetch_token; 
prograra_main_block; 
verify_token (token,  semicolon) ; 

if  no_local_variable [procedure_level]  >  max_local_variable  then 

write_error( * maximum  number  of  local  variable  exceeded  limit  *, token); 
for  i  1  to  no_local_variable(procedure_level]  do 
begin 

{  writeln (outfile, ’delete  from  symbol  table  :  , local_variable [procedure_level, i] , ' "* ) ;  } 

delete_symbol (local_variable [procedure_level, i] ) ; 
end; 

if  write_lookahead_buffer  (1]  .id  <>  blank__token  then  generate_Nop; 
writeln (outfile, * ; ’ ,prograra_counter, ’ :  return' ) ; 
microcode_address  :•  program_counter ; 

AM2910_opcode  CRTN; 

branch_opcode  unconditional; 

output  _microcode_field; 
prograra_counter  program_counter  +  1; 
fetch_token; 

for  i  0  to  max_index__register  do  indexer egi st er (i)  blank_token: 

procedure_level  :•  procedure_level-l ; 

writeln (outfile, end  of  procedure  ’ ,procedure_name, '  )*  ); 
end;  (  of  procedure_main_block  } 

Procedure  function_main__block; 
var  i  :  longint; 

function_name  :  token_type; 
begin 

for  i  0  to  max_index_register  do  index_register (i)  blank_token; 
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fetch_token;  {  function_name  } 
functionjname  token; 

writeln (out file, * ;  (  function  * , function_name) ; 
symbol_type  function__symbol_type; 
symbol__value  :  -  program_counter ; 

insert_syrabol(function_name, symbol_type, symbol_value) ; 

no_local_variable{procedure_levell  no_local_variable [procedure_level] +1; 

local_variable [procedure_level,no_local_variable [procedure^ level] ]  function_narae; 

procedure_level  procedure_level+l; 

inside_function_block(proced'ure_level]  :«*  true; 

if  procedure_level  >  max_procedure_level  then 

begin 

writeln (error file) ; 

writeln (errorfile, *  1 ! !  error,  maximum  procedure  nesting  level  exceeded,  max  -  * ,raax_procedure_level) 
error_found; 
end; 

no_loca l_va r iable ( procedur e_leve 1 ]  :-0; 

fetch_token; 

par ameter_list ; 

find_symbol (function_name, symbol_type, syrobol_value, found) ; 

verify_token (token, colon) ; 

fetch_token; 

if  token  -  real_token  then 

■ymbol^type  real_syrabol_type 

else 

if  token  -  integer_token  then 

symbol_type  integer_symbol_type 

else 

if  token  -  boolean_token  then 

symbol_type  boolean_symbol_type 
else 

write_error ( ’unsupported  function  type  :  *, token); 

new(new_parameter) ; 

new_j>ar amet erA .id  : -  function_name ; 
new_parameterA .id_type  symbol_type; 

new_pararaeter~.next  nil; 

insert_symbol ( function_name, syrabol_type, symbol_value) ; 
new jparameter*. address  syrabol_value; 

if  procedur e_link~ .pa rameter_link  -  nil  then 
begin 

procedure_linkA.parameter_link  newjparameter; 

end 

else 

begin 

nev_parameter,,k . next  procedure^ink'* .parameter_link; 
procedure^ink'*  .parameterJLink  new_parameter; 

(  current_parameter  procedure_linkA .parameter_link; 

while  current_parameter'“ . next  <>  nil  do  current_parameter  current_parameter^ .next; 
current_pararaeter,,‘ .next  ;*  new_parameter;  } 
end; 

no  local_variable [procedure_level]  no_local_variable (procedure_level] +1; 
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local_yariable [procedure_level, no_loca Invariable [procedure_level] ]  f unction_name ; 

{  current_j>araraeter  procedure_linkA.parameter_link; 
writeln (outfile, ’beginning  of  listing  of  parameter  inside  procedure*); 
while  current_pararaeter  <>  nil  do 
begin 

writeln( out file, *current_j>arameter  id  :  ’,current_parameterA.id) ; 

writeln (out file, *current_pararaeter  id_type  :  ' , current  j3arameterA.id_type) ; 
writeln (out file, *current_parameter  address  :  cur rent_pararaeter A . address ) ; 

currentjsararaeter  current_parameterA.next; 
end;  ) 

fetch_token; 

verify_token (token, semicolon) ; 
fetch_token; 
pr ogram_mainjDlock ; 
verify__token (token, semicolon) ; 

if  no_local_variable tprocedure_level)  >  max_local_variable  then 

writ e_error ( ’maximum  number  of  local  variable  exceeded  limit  ’, token); 

for  i  1  to  no_local_variabletprocedure_level]  do 
begin 

(  writeln (outfile, ’delete  from  symbol  table  :  *”,  local_variable(procedure_level,  i]  ,’’’*) ;  } 
delete_symbol(local_variable[procedure_level, i] ) ; 
end; 

if  write_lookahead_buffer [1] .id  <>  blank_token  then  generate^Nop; 
writeln ( outfile , ' ; * , prograra_counter , ’ s  return ’ ) ; 
microcode_address  prograra^counter; 

AM2910_opcode  CRTN; 

branch_opcode  unconditional; 

output_microcode_f ield ; 
program^counter  program_counter  +1; 

fetch_token;  - 

for  i  ;■  0  to  max_index_register  do  index_register {i]  blank_token? 
inside_function_Jblock[procedure_level]  false; 
procedure_level  procedure_level-l; 

writeln  (outfile,  * ;  end  of  function  ' ,  function__name,  '  )’  ); 
end;  {  of  function  main  block  } 


File:  STDPROCD.DEF 


public  stdprocd; 

Procedure  pr ocedure_s to re_f unction ; 
Procedure  procedure_store_window; 
procedure  procedure_read_function; 
Procedure  procedure_gt_ffs; 
Procedure  standard__procedurejolock; 
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File:  STDPROCD . PAS 
module  stdprocd; 

$include ( stdprocd . def ) 

$include (global . def) 

Sinclude (utility. def) 

$include ( expr sion . def) 

$include (exprtree . def ) 

$include  (code__gen .  def) 

Sinclude ( io . def) 

$include (fetch_tk.def) 

Sinclude (arith.def) 

Sinclude ( symbol_t . de  f ) 

$ include (bit_func.def) 

$include ( erau^lib .def) 
private  stdprocd; 

Procedure  procedure_store_f unction; 
var 

x, fx  :  operand_type; 
begin 

fetch_token; 

verify_token (token. open_parenthesis) ; 

fetch_j?arameter (x) ;  check_operand_type (x, real_symbol_type) ; 
verify_token (token, comma) ; 

fetch_pararaeter  (fx) ;  check__operand_type  (fx,  real_symbol_type) ; 
verify_token (token , close_parenthesis) ; 
find^aymbol (fx.id,  fx.id__type,  fx.  id_address,  found) ; 
if  not  found  then 

write_error ( ’ unknow  id : 
fx.index_address  :-  assign__index (fx. index) ; 
find_syrabol(x.id, x.id_type,x.id_address, found) ; 
if  not  found  then 

write_error ( 'unknow  id: 
x.index_address  :-  assign__index  (x. index)  ; 
reset_microcode_field; 
clear_pipeline_stage; 
operand_string(x,  temp_token).; 

write  (outf ile,  *  ,*  store_function  ( * ,  temp_token,  * ,  * )  ; 
operand_string(fx,  terap_token) ; 
writeln  (outfile,  temp__token,  ')'); 
microcode_address  :-  program_counter; 

AR  :-  fx.id_address  +  fx. offset; 
if  fx. index  <>  blank_token  then 
begin 

AIR{0]  :-  fx. index_address; 

IAX  1; 
end; 

AS  :-  1; 

out  put_mi  cro  co  de_f  ie  1  d ; 
program_counter  program_counter+l; 
microcode_address  :»  prograra_counter; 


’ , fx.id) ; 


’ ,x. id) ; 
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AR  x.id_address  +  x. offset; 

if  x. index  <>  blank_token  then 
begin 

AIR  10]  x . index_addres  s ; 

IA1  s-  1; 
end; 

AS  AR; 

AIS [ 0 ]  :-AIR[0]; 

IA0  !-  IAl; 

output_microcode_field; 
prograra_counter  prograra_counter+l; 
microcode_addre  s  s  prograra_counter ; 
write_opcode  atore_ function^opcode; 

output_microcode_field; 
program_counter  i—  prograra_counter+l; 
stack_pointer  stack_pointer  -  2; 
end;  {  of  store_function  } 

Procedure  pr ocedur e_st ore_window ; 
var  window  :  longint; 

tl,t2  :  operand_type; 
i  :  longint; 
begin 

fetch_ token; 

verify_token (token, open_parenthesis) ; 
fetch_token; 

if  symbol_type  <>  integer__constant_symbol_type  then 
write_error(* constant  expected  : 
window  integer_constant_value; 

find_symbol (token, syrabol_type, symbol_value, found) ; 

if  not  found  then 

begin 

insert_syinbol  (token,  symbol_type,  symbol_value) ; 
declare^ constant (syrabol^value, symbol^type, token) ; 
end; 

assign_temp_pararaeter (tl, real_symbol_type) ; 
tl .id  token; 

assign_temp_parameter (t2, integer_symbol_type) : 
generate_ALU_operation(t2, tl, zero_operand, unary_round)  ; 
clear_pipeline_stage; 

writeln (out file, ' ;  store_window ( » , window, * ) ’ ) ; 
microcode_address  program_counter ; 
delete (t2 . id, 1,1); 
val_integer (t2.id,AR,i) ; 

AS  AR; 

output_raicrocode_field; 
prograra_counter  program_counter  +  1; 
microcode_address  program_counter; 
write_opcode  store_window_opcode; 
output_microcode_field; 
programjrounter  program_counter+l; 


* , token) ; 
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fetch_token; 

verify_token( token, close_parenthesis) ; 
end;  {  of  procedure_store_window  ) 

procedure  procedure_read_ function; 
var 

x, fx  :  operand_type; 
function_jiumber  :  longint; 
begin 

fetch_token; 

verify_token {token, open_parenthesis) ; 
fetch_token; 

if  syrabol_type  <>  integer_con3tant_symbol_type  then 
write_error (* integer  constant  expected  : 
function_number  :•  integer_constant_value; 
if  (function_nurober  <  0)  or  (function_number  >  1)  then 
write_error ( ’  function  out  of  range  ; 
fetch_token; 

constant_aa*ignment_type  real_con9tant_syrabol_type; 
verify_token {token, comma) ; 

fetch_parameter (x) ;  check_operand_type {x, real_symbol_type) ; 
verify_token (token, comma) ; 

fetch_parareeter  (fx)  ;  check_^operand_type(fx,  real_symbol_type) ; 
verify_token (token, close_parenthesis) ; 
find_syrabol (fx. id, fx.id_type, fx.id_address, found) ; 
if  not  found  then 

wr it e_err or ('unknow  id: 
fx.lndex_address  a«sign_index (fx. index) ; 
find_3ymbol(x.id,x.id_^type,x.id_address,  found) ; 
if  not  found  then 

write_error (' unknow  id: 
x.index_address  :•  assign_index (x. index) ; 
re3et_microcode_field; 
clear_pipeline_stage; 
operand_string(x,  temp_token) ; 

write (out file, ’ ;  read_function ( * , temp^token, ’ ,  * ) ; 
operand_string(fx,  temp_token) ; 
writeln  (outfile,  temp_token,  ’)’); 
microcode_address  :-  program_counter; 

AR  x.id_address  +  x. off set; 
if  x. index  <>  blank_token  then 
begin 

AIR[0]  x.index_address; 

IA1  1; 

end; 

AS  AR; 

IA0  IA1; 

output_microcode_field; 
program_counter  :-  program_counter  +  1; 
microcode_address  program_counter; 

AF [ 0 J  fx.id_address  +  fx. offset; 


', token) 


* , token) 


* , fx.id) 


' , x . id) ; 
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if  *. index  <>  blank_token  then 
begin 

AIFIO]  fx.index_addreas; 

IA2 [ 0 ]  1; 

end; 

write_opcode  read_function_opcode  +  function_number 
output_microcode_field; 
prograra_counter  prograra_counter  +1; 
end;  {  of  procedure_function_read  ) 

procedure  procedure_gt_ffs? 
var  f, r,s  :  operand_type; 

function_number  :  longint; 
begin 

fetch_token; 

verify_token (token, open^parenthesis) ; 
fetch_token; 

if  syrobol_type  <>  integer^ constant_symbol_type  then 
write_error (token, 'function  number  expected 
function_number  integer_constant__value; 
fetch_token; 

verify_token (token, comma) ; 
f etch^operand ( f ) ; 
fetch_token; 

verify_token (token, comma) ; 

f e tch_pa  r ameter ( r ) ; 

verify_token (token, comma) ; 

f etch_j»araraeter  ( s ) ; 

write (outfile, * ; * ) ; 

operand_string ( f ,  terap_token) ; 

write_token  (outfile,  temp_token) ; 

write (  *  :-  GT_FFS ( ' ,  function_number,  *,’); 

operand_string(r,  temp_token) ; 

write_token  (outfile,  temp_token) ; 

write  (',*>; 

operand_string (s,  temp_token) ; 
write_token  (outfile,  temp_token) ; 
writeln  O'); 

verify^to ken (token, close_parenthesis) ; 
find_syrabol(f .id, f .id_type, f ,id_address, found) ; 
if  not  found  then 

write_error ( ’ unknown  id: 
f . index_address  assign_index (f. index) ; 

find_symbol(r.id,r.id_type,r.id_address. found) ; 
if  not  found  then 

write_error ( ’ unknown  id : 

r . index_addre39  aasign^index (r .index) ; 

find_symbol (s . id, s . id_type, a . id_address, found) ; 
if  not  found  then 

write_error ( 'unknown  id: 

s. index_address  assign_index (s . index) ; 
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clear_pipeline_st  age ; 
reset_microcode_field; 
raicrocode__address  program_counter ; 

AR  r.id_address  +  r. off set; 
if  r. index  <>  blank_token  then 
begin 

AIR[0]  r.index_address; 

IA1  s-  1; 
end; 

AS  s.id_address  +  s. offset; 

if  s. index  <>  blank_token  then 
begin 

AIS [0]  s.index_address; 

IAO  1; 

end; 

output_microcode_field; 
program_counter  program_counter+l; 
microcode_address  :•  program^ counter; 

AF[0]  f.id_address  +  f. offset; 

if  f. index  <>  blank_token  then 
begin 

AIF[0]  ;•  f ,index_address; 

IA2[0J  1; 

end; 

rase  word_and  (function_number,  1); 
write_opcode  vord_shr (function_nuraber,  1); 
output jmicrocode_f ield; 
program_counter  prograra_counter+l; 
end;  t  of  procedure_gt_f f s  } 

Procedure  standard_procedure_block; 
begin 

if  (token  -  send)  or  (token  -  sendjmsw)  or  (token  -  send_lsw)  then 
begin 

send_procedure ; 
end 

else 

if  (token  -  receive)  or  (token  -  receive_msw)  or  (token  -  receive__lsw)  then 
begin 

receive_jjrocedure; 

end 

else 

if  token  -  store_function  then 
procedure_store_function 
else 

if  token  -  store^window  then 
procedure_store_window 
else 

if  token  -  read_function  then 
procedure_read_function 


else 
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if  token  -  proc_reset  then 

begin 

end 

else 

if  token  •  gt_ffs_token  then 
begin 

procedure_gt_ffs 

end; 

fetch_token? 

end;  {  of  stands rd_procedure_block  }. 
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File:  STRI.PAS 

program  stri  (input,  output) ; 
const 

blank_token  -  * 

type 

token_type  -  packed  array  [1..50]  of  char; 

var 

j,  p  s  integer; 

i  :  longint: 

striin,  striout  s  text; 

1  :  token__type; 

procedure  atr_integer  (  1  :  longint;  var  token  :  token_type) ; 
var 

i,  j,  k  :  integer; 
terap_char  :  char; 

begin 

token  blank_token; 

i  1; 

j  1; 

if  1  -  0  then 
begin 

k  2; 

token [1]  ’O’ 

end 

else 

begin 

if  1  <  0  then 
begin 

token(i) 
i  i  +  1 
end; 
j  i; 

1  abs ( 1 ) ; 

writeln  ( *  1  -  *,1); 
while  1  >  0  do 
begin 

token [i]  chr  ((1  mod  10)  +  30H) ; 

writeln  (  'token( * , i, * ]  *,  token[i)); 

1  1  div  10; 

i  i  +  1 

end; 
k  i; 

i  i  -  1; 

while  j  <  i  do 
begin 

Temp_Char  : -  token [i ] ; 
token t i]  token(j); 
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token [ j ]  : -  t erap_char ; 

j  f-  j  +  1? 
i  i  -  1 
end; 

end; 

end;  {  str_integer  ) 


begin 

rewrite  (striout,  * striout*) ; 
reset  (striin,  *  s  $ : striin* ) ; 
while  not  eof( striin)  do 
begin 

readln  (striin,  i) ; 
str_integer  (i,l); 
j  0; 

for  j  1  to  50  do 

write  (striout, 1 (j] ) ; 
writeln( striout) 
end 


end. 
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File:  STRR.PAS 

program  strr  (input#  output); 
const 

blank_token 

type 

token_type  -  packed  array  [1..50]  of  char; 


j#  p  :  integer; 
i  :  real; 
x  :  token_type; 
strrin,  strrout  :  text; 


function  x_to_the_y  (  x  :  real  ;  y  :  integer  )  ;  real; 

var 

i  :  integer; 
total  :  real; 

begin 

total  1; 

for  i  1  to  y  do 

total  total  *  x; 
x_to_the_y  total 
end;  {  x_to_the_y  } 

procedure  str_integer  (  1  :  longint;  var  token  :  token_type); 
var 

i,  j,  k  :  integer; 
temp_char  :  char; 

begin 

token  blanket oken; 
i  1; 

j  1; 

if  1  -  0  then 
begin 

k  2; 

token (1]  'O’ 

end 

else 

begin 

if  1  <  0  then 
begin 

token  I i] 
i  i  +  1 

end; 
j  i; 

1  abs(l); 


writeln  ( *  1  -  \1); 
while  1  >  0  do 
begin 

token [i]  chr  ((1  mod  10)  +  30H) ; 

writeln  {  'token [ • ,i, ' ]  token (i] ); 

1  1  div  10; 

i  i  +  1 

end; 
k  i; 
i  s-  i  -  1; 
while  j  <  i  do 
begin 

Temp_Char  ; -  token ( i ] ; 
token (ij  token [jj; 

tokenfj]  s-  temp_char; 
j  j  +  1; 

i  s-  i  -  1 

end; 

end; 

end;  {  strjinteger  ) 

procedure  str_real  <  *  :  real;  var  string  :  token_type  ) 

var 

base,  mantissa,  fraction  :  real; 
i,  j,  exponent  :  integer; 
terap_string  ;  token_type; 

begin 

string  blank_token; 
if  x  -  0  then 
exponent  0 
else 

begin 

exponent  ltrunc  (In  (abs (x) ) /In (10) ) ; 
if  (exponent  <  1)  and  (abs(x)  <  1)  then 
exponent  exponent  -1 

end; 

if  exponent  <  1  then 
base  10 

else 

base  0.1; 

mantissa  :•  x  *  (x_to_the_y  (base,  abs (exponent) )) ; 
str__integer  (ltrunc  (mantissa) ,  temp_string)  ; 
i  1; 

stringti]  temp_string[i] ; 
if  temp_string{2]  <>  '  *  then 
begin 

i:-  i  +  1; 

string [i]  temp_string(i] 


end; 
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i  i  +  1; 

string  (±1  *.*; 

fraction  s-  abs (mantissa) ; 
for  j  :•  1  to  10  do 
begin 

fraction  fraction  -  ltrunc ( fraction) ; 

fraction  fraction  *  10; 

•tr_integer  (ltrunc ( fraction) ,  temp_string) ; 
stringti  +•  jl  :»  temp_string[l] ; 
end; 

i  i  +  j  +  1; 

stringti]  ’e'; 

str_integer  (exponent,  temp_string) ; 
for  j  s-  1  to  3  do 

stringti  +  j]  j-  terop_string [ j ] ; 
end;  (  str_real  } 

begin 

rewrite  ( strrout  r  f : $ : strr out ' ) ;  < 

reset  ( str rin ,  * : $ ; strr in ' ) ; 
while  not  eof(strrin)  do 
begin 

readln  (strr in,  i) ; 
str_real  (i,x); 
j  0; 

for  j  1  to  SO  do 

write  (strrout,x( j] ) ; 
writeln ( strrout ) 
end 


end. 
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rile:  SYMBOL_T.DEF 
public  sy»bol_t; 

Procedure  delete_symbol  {symbol_name :  toJcen_type)  ; 

Procedure  find_symbol  (syrabol^narae:  token^type;  var  symbol_type, 

ayrabol_value:longint;  var  found  :  boolean) 
Procedure  insert_symbol { syrabol_name : token_type : symbol_type : integer; 

var  syrabol^value  :longint) 
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.File:  SYMBOL_T.PAS 
module  symbol_t; 
public  syrabol_t; 

$include ( global . de  f ) 

$ include { f etch_tk . def) 

^include (utility . def ) 

$include (bit_func. def ) 

$include { erau_lib .def) 

$include ( symbol_t . def) 
private  symbol_t; 

function  hash (token  :  token^type) : longint; 
var  g,h, i  :  longint; 
begin 
h  0; 

for  i  1  to  length (token)  do 

begin 

h  word_shl(h,  4)  +  ord (token [i] ) ; 
g  :«  vord_and(h,  OfOOOH); 

(i  12.  Assign  unsigned  values  of  $8000  or  larger  only  to  Word  or  Longint  types.) 
if  g  <>  0  then  h  wordxor (h,  wordshr  (g,  12)); 
end; 

if  h  <  0  then  h  word_shr(h,  1); 
h  h  mod  prime; 
hash  h; 

end; 

Procedure  delete_symbol ; 
var  h  ;  longint; 
begin 

h  hash(symbol_name) ; 
found  false; 

(*  search  the  list  for  a  match  to  input  name  *) 

current_symbol  first_symbol [h] ;  (*  start  search  at  head  of  list  *) 

if  symbol_name  -  first_symbol [hi * .name  then 

begin 

if  first_3ymbol[h] *.next  -  nil  then 
begin 

dispose (first_syrabol(h] ) ; 
first_syrabol [h)  nil; 

end 
else 
begin 

first_symbol(h)  current_symbol'' .next; 

dispose (current_symbol) ; 
end; 
end 
else 
begin 

While  ( cur rent_symbol'‘. next  <>  nil)  and  {not  found)  do 
Begin 


Digital  Emulation  Technology  Laboratory  Final  Recart 


213 


found  (symbol_name  -  current_symbolA .next A .name) ;  (*  is  symbol  stored  in  this  record  ?  *) 

if  not  found  then 

current_symbol  cur rent_symbolA .next  (*  advance  if  not  found  *) 

end;  {*  of  while  *) 
if  found  then 
begin 

(*  delete  symbol  from  the  entry  *) 
new_symbol  j-  cur rent_symbolA .next; 
current_symbolA .next  new_symbolA .next; 
dispose (new_symbol) ; 
end 
else 
begin 

write  error ( *  symbol  to  be  deleted  not  found  :  * , symbol_name) ; 

end; 
end; 

end;  (  of  delete_symbol  } 

Procedure  find_syrabol (syrabol_name:token_type;var  symbol_type, symbol_value: 

longint;  var  found  ;  boolean); 

label  1? 

var  h  ;  longint; 

current^ symbol  :  symbol_pointer ; 
old_symbol_type  :  longint; 
dummy__integer  :  longint ; 
begin 

if  ( symbol_narae [  1  ]  -  '#*)  or  (symbol_narae [1]  -  '4*)  then 
begin 

symbol^ name [1 ]  'O'; 

val_int eger ( syrabol_narae , symbol_value , h) ; 

if  h  <>  0  then  wr it e_error {’ Invalid  symbol  search  :  ’ , syrabol_name) ; 

found  true; 
goto  1;  (  exit  } 
end; 

h  hash<3ymbol_name) ; 
found  false; 

old_symbol_type  symbol_type; 
symbol_type  s-  general_syrabol_type; 

current_symbol  first_symbol{h] ;  {*  start  search  at  head  of  list  *) 

{*  search  the  list  for  a  match  to  input  name  *) 

While  (current_symbol  <>  nil)  and  (not  found)  do 
Begin 

found  <symbol_narae  -  current_symbolA.name) ;  (*  is  symbol  stored  in  this  record  ?  *) 

if  not  found  then 

begin 

{  writeln (out file, *  find  symbol  :  ' , current_symbolA .name, * - >  r , current_symbolA .value) ;  } 

current  symbol  current_symbolA . next  (*  advance  if  not  found  *) 
end; 

end;  <*  of  while  *) 
if  found  then 
begin 
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(*  return  value  that  was  stored  In  table  *) 
syrobol_value  cur rent__syrabol* .value ; 

symbol_type  : -  cur r en t_symbol * . symbol_type  ; 
if  (symbol_type  -  procedure_syrabol_type)  or 
(symbol_type  -  function_symbol_type)  then 
procedure^link  :«  current_sy7ttbol; 
if  symbol_type  -  integerjsonstant^symbol^ype  then 

integer_constant_value  lround (current_symbol*.constant_value) 
else 

if  synbol_type  -  real_constant_symbol_type  then 

real_constant_value  : -  current_syrabol~ . constant_value ? 

end 

else 

begin 

(  restore  the  symbol_type  if  not  found  } 
symbol_type  old_symbol_type; 
end; 

1:  {  exit  J 

end;  {  of  find^symbol  } 

Procedure  insert__symbol; 
var  h  s  longint; 

found  :  boolean; 
begin 

(  writeln(outfile, ' -  beginning  of  insert^symbol  -  *); 

writeln (out file, *  inserting  :  " * , symbol_narae, * " ' ) ;  } 

h  hash(symbol_narae) ; 
found  false; 
new (new_syrabol) ; 

new_symbolA.next  s-  first_symbol [h] ; 
new^symbol* ,pararaeter_link  nil; 
new__syrabol*.narae  symbol_narce; 
new_symbol''.symbol_type  symbol_type; 
new_syrabol-'.  scope  procedure_level ; 

first_symbol [hi  new_symbol; 

current_sywbol  first^syrabol  [h] ‘'.next; 

while  current^symbol  <>  nil  do 
begin 

{  writeln(outfile, 'symbol*. name  :  * , current_symbol* .name) ;  ) 
if  current_symbol‘' .name  -  symbol_name  then 
begin 

if  cur  rent_3ymbol‘'.  scope  -  procedure_level  then 
begin 

writ e_error ( 'duplicate  id  symbol  name); 

end; 
end; 

current_syrabol  cur rent_symbol*. next; 

end; 

if  {symbol_type  -  real_symbol_type)  then 
begin 

new_symbol‘'. value  next_dataram_location; 
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symbol_value  t-  new_symbol*.  value; 

write (out file, * ) ; 

write_token  (out file,  »yrabol_name) ; 

writeln  (outfile,  *  - >  ’ , symbol_value, ’  (real)*); 

end 

else 

if  (syrabol_type  •*  boolean_syrebol_type)  then 
begin 

new_syrabol*. value  next__dataram_location; 

symbol_value  new^symbol* .value; 

write (outfile, *;  '); 

writ e— token  (outfile,  symbol_name) ; 

writeln  (outfile,*  - >  ' , symbol_value, *  (boolean)') 

end 

else 

if  ( syrabol_type  -  real_constant_symbol_type)  then 
begin 

new_syrabol* . value  s*  next_datarara_location; 
symbol_value  s*  new_syrnbol* .value; 

new_ayrabol* . constant_value  : -  real_constant_value; 

write (outfile, * ;  * ) ; 

write_token  (outfile,  ayrabol_name) ; 

writeln  (outfile,*  - >  * , symbol_value, '  (real  constant)'); 

end 

else 

if  ( symbol_type  -  boolean_constant__syrabol_type)  then 
begin 

new_syrabol* .value  next_dataram_location; 

symbol_value  new_syrabol* .value ; 

new^symbol* . constant_value  real_constant_value; 

write (outfile, *;  * ) ; 

write_token  (outfile,  syrabol_name)  ; 

writeln  (outfile,*  - >  ’ , syrobol_value, ’  (boolean  constant)*); 

end 

else 

if  (symbol_type  -  integer_symbol_type)  then 
begin 

new_symbolA .value  next_dataram_location; 

symbol_value  new_symbol* .value; 

write (outfile, * ;  * ) ; 
write_token  (outfile,  symbol_name) ; 

writeln  (outfile,*  - >  * , symbol_value, '  (integer)*); 

end 

else 

if  (symbol_type  —  integer_constant_symbol__type)  then 
begin 

new  symbol*. value  : ■  next_dataram_location; 
symbol_value  new_symbolA .value ; 

new_symbol*.constant_value  integer_constant_value ; 
i  next__dataram_location;  {  advance  dataram  address  ) 


write (outfile, ' ;  ’ ) ; 
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write_token  (out file,  symbol_name) ; 

writeln  (outfile, *  - >  * , syrabol_value, *  (integer  constant)’)? 

end 

else 

if  (symbol_type  -  real_ array_symbol_type)  then 
begin 

syrabol_value  datarara_address  -  array_lower_range; 
new_symbol*. value  syrobol_value? 

datarara_address  dataram^address  +  (array_upper_range-array_lower_range) 
+  1; 

i  next_datarara_location;  {  advance  datarara  address  } 

write (outf ile, * ;  * ) ? 

write_token  (out file,  symbol_name) ; 

writeln  (outfile, *  - >  ’ , syrabol_value, ’  (real  array)’); 

end 

else 

if  (symbol_type  -  integer_array_symbol_type)  then 
begin 

syrabol_value  datarara_address  -  array_lower_range; 
new_syrabol*. value  syrabol_value; 

dataram_address  dataram_address  +  (array_upper_range-array_lower_range) 
+  1? 

i  s-  next_dataram__location;  {  advance  dataram  address  ) 

write (outfile, * ;  * ) ? 

write_token  (outfile,  syrabol__name) ; 

writeln  (outfile,*  - >  * , symbol_value, *  (integer  array)'); 

end 

else 

if  (symbol_type  -  boolean_array_symbol_type)  then 
begin 

symbol_value  datarara_address  -  array_lower_range; 
new_symbol'‘.  value  symbol_value; 

dataram_address  dataram_address  +  (array_upper_range-array_lower_range) 
+  1; 

i  next__datarara_location;  {  advance  dataram  address  ) 

write (outfile, ’ ?  ’ )  ; 

write_token  (outfile,  symbol_name) ; 

writeln  (outfile,*  - >  * , syrabol_value, ’  (boolean  array)’); 

end 

else 

if  (syrabol_type  -  procedure_symbol_type)  or 
(symbol_type  -  function_symbol_type)  then 
begin 

new_symbol''.parameter_link  nil; 
new_symbol~ . value  symbol_value; 
procedure_link  :•  new_symbol; 
write (outfile, ';  ’); 
write_token  (outfile,  symbol  jname ) ; 

writeln  (outfile,’  - >  * , symbol_value, ’  (procedure/function) *) ; 

end 


else 
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if  (symbol_type  -  label_ayrabol_type)  then 
begin 

new^symbol* .value  symbol_value; 

write (outfile,  ’ ;  *); 

write_to)cen  (outfile,  syrabol_name) ; 

writeln  (outfile,’  - >  ’ , symbol_value, *  (label)’); 

end; 

(  writeln  (outfile, ’insert  symbol  :  ’ ,new_syrabol'%.name,  ’ - >  *,i 

new_symbol* .value) 

end;  (*  of  insert_symbol  *) . 


File:  UTILITY. DBF 
public  utility; 

procedure  assign_stack_operand(var  operand  :  operand_Type;op_type: longint) ; 

Procedure  verify_token (token, expected_token  :  token_type) ; 
procedure  error_found; 

procedure  write__error  (error_message,  token  :  token_type) ? 

Function  next_datarara_location  :  longint; 

Procedure  assign_percent_variable (var  token  :  token_type); 

Function  next_temp_yariable_location  :  longint; 

Procedure  reset_temp_variable_address; 

Procedure  declare^constant (ram_address, const ant_type:  longint? const ant_id  :  token_type) 

procedure  operand_st ring (operand  :  operand_type;  var  token  :  token^type) ; 

procedure  check_operand_type (operand  ;  operand_type ;symbol_type: longint ) ; 

procedure  reset_stack_pointer; 

procedure  free_stack_operand; 

procedure  decrement_stackjpointer; 

procedure  assign_terap_variable (var  variable  :  token_type) ; 
procedure  reset_operand(var  operand  :  operand_type) ; 
procedure  simplify_type(var  symbol_type :  longint ) ; 
procedure  assign_dumray_pararaeter (var  parameter : operand_type) ; 
procedure  assign_parameter (var  parameter:  operand_type; 

pararaeter_type  : longint); 

procedure  assign_temp__pararaeter  (var  parameter:  operand_type; 

parameter_type  :  longint); 

procedure  assign_parametric_operand(var  parameter:  operand_type) ; 

procedure  fetch_expression(var  F,R,S  :  operand_type;  expression  :  expression_pointer) ; 
procedure  store_expression(var  F,R,S  :  operand_type ;  expression  :  express ion_pointer) ; 
procedure  clear_index_register; 
procedure  clear_temp_index; 
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File:  UTILITY. PAS 
module  utility: 

$include (pqclose . def ) 

$include (utility. def) 

^include ( global . de  f ) 

$include (emu_lib.def) 

$include <ieee_cnv . def) 
public  UDI; 

procedure  dgexit  (completion_code  :  word) ; 
private  utility; 

procedure  clear_terap_ index; 

var  i  :  integer; 

begin 

for  i  0  to  raax_index_register  do 
begin 

if  index_register (ij [1]  -  ’s'  then 
index_regi«ter [i]  blank_token; 

end; 

end; 

procedure  clear_index_register; 

var  i  s  integer; 

begin 

for  i  0  to  max_index_register  do 
begin 

index_register [i]  blank_token; 
end? 
end; 

procedure  assign_stack_operand(var  operand  :  operand_Type;op_type:longint) ; 
begin 

str  integer (stack_pointer, operand. id) ; 
temp_token  blank_token; 
terap_token ( 1 ]  : -  ' # f ; 
concat  (temp_token,  operand. id); 
operand. id  :  —  temp_token? 
operand. id_type  op__type; 
operand. index  blanX_toXen; 
operand. offset  0; 
decrement_stacX_pointer; 
end;  {  assign_stack_operand  ) 

Procedure  verify__toXen  (token.  expected_token  :  token_type) ; 
begin 

if  token  <>  expected_token  then 
begin 

vriteln(errorfile) ; 

writeln (errorfile, * ! S  L I  syntax  error  , " token, ' "  received'); 
writeln (error file, *  M\ expect ed_token, expected'} ; 

error  found; 
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«nd; 

end;  {  of  verify_token  ) 

procedure  error_found; 
var 

corapletion_code  :word; 
begin 

gotoxy (5, 12) ; 

write! 'Check  error  at  ;  '); 
vrite_token  (output,  error_filename) ; 
gotoxy (5, 24) ; 
pqclose  (errorfile) ; 
pqclose  (outfile) ; 
pqclose  ( const ant_f lie) ; 
dqexit (completion_code)  {  halt  ) 
end;  (  of  error_found  } 

procedure  write_error  (  error_raessage,  token  !  token_type) ; 
var 

corapletion^code  :word; 
begin 

writeln( error file) ; 

write (errorfile, ' ! ! !  Error,  * ) ; 

write_token  (errorfile,  errorjnessage) ; 

write  (errorfile,""); 

write— token  (errorfile,  token) ; 

writeln  (errorfile,  ""); 

gotoxy (5, 12) ; 

write ('Check  error  at  :  '); 
write_token  (output,  error_filename) ; 
gotoxy (5, 24 ) ; 
pqclose  (errorfile) ; 
pqclose  (outfile) ; 
pqclose  (constant_file) ; 
dqexit (corapletion_code)  (  halt  ) 
end; 

Function  next_datarara__location  :  longint; 

Begin 

if  dataram_addres3  <  datarara_address_lirait  -  temp_variable_limit  then 
begin 

next_dataram_location  dataram_address;  (*  return  memory  spot  *) 
dataram_address  dataram_address+l;  (*  point  to  next  spot  *) 

(  if  (symbol_type  -  integer_symbol_type)  or 

(symbol_type  -  integer_constant_symbol_type)  then 
dataram_address  :»  dataram_address+l;  } 

end 

else 

begin 

writeln (errorfile) ; 

writeln (errorfile, 'Data  ram  memory  Overrun,  too  many  variables'); 
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writeln(errorfile, ’Maximum  number  of  variables  allowed  ' 

, dataram_address_limit) ; 


•rror_found; 

end; 

end;  (  of  next_dataram_loeation  } 


procedure  assign_percent_variable(var  token  j  token_type) ; 
var  i  ;  longint; 
temp__string  :  token_type; 
begin 

terap_string  blank_token; 
token  blanket oken; 

percent_yariable— counter  percent_variable_counter  +  1; 

str_integer  (percent_variable_counter, token) ; 
temp__string  [  1  ]  :  -  *  %  * ; 
concat  (tempest ring,  token) ; 
token  terap_string; 
end;  {  of  assign_percent_variable  ) 

Function  next_temp_variable_location  s  longint; 

Begin 

if  inside_function_block[procedure_levell  -  false  then 
begin 

if  terap_variable_address  <  stack_pointer  then 
begin 

next  temp  variable  location  :«■  temp_variable_address;  (*  return  memory  spot  *) 
temp_variable_address  :  —  temp_variable_address+l;  (*  point  to  next  spot  *) 
end 
else 
begin 

writeln(errorfile) ; 

writeln (errorf ile, 'Data  ram  memory  Overrun,  too  many  variables'); 
writeln( err or file, 'Maximum  number  of  variables  allowed  ' 

, datarara_address_lirait) ; 

error_found; 

end; 

end 

else 

begin 

next_terap_variable_location  next_dataram_location; 
end; 

end;  {  of  next_temp_variable_location  ) 

Procedure  reset_temp_variable_address ; 
begin 

{  if  write_lookahead_buffer {01 .id[l]  -  '**  then 
write__lookahead_buffer [0]  , id  } 

terop_variable_address  dataram_address_limit  -  temp_variable_limit  +1; 

{note  that  the  location  dataram_address_limit-temp_variable_limit  is  reserved 
for  temporary  boolean  variable  to  avoid  conflict  with  the  pipeline  assignment) 
end;  {  of  reset_temp_variable_address  } 
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Procedure  declare_constant (ram_address, constant_type : 

longint; constant_id  :  token_type) ; 

var  msw.lsw  :  word; 
begin 

if  (constant_type  -  real_con3tant_syrabol_type)  or 

(constant_type  -  boolean_constant_syjnbol_type)  then 
begin 

Real_to_IEEE (real_constant_yalue,rasw, law) ; 

writeln  (constant_file, * ;declare  constant  *,  rara_address, 

'  -*->  ' , real_constant_value, *  (real)*); 
writeln (constant_file, *v  *,ram_address, '  *  ,msw, '  * ,lsw); 
end 
else 

if  constant_type  -  integer_constant_synibol_type  then 
begin 

real_constant_value  integer_constant_value; 
Real_to_IEEB(real_eonstant_value,rasw, law) ; 

writeln (constant_file, declare  constant  * , ram_address, *  - >  ’ 

, real_constant_value:10:9, *  (real/integer) M ; 
writeln (constant_file, *v  * , ram^address,  *  '  ,msw, ’  ',l3w); 
end 
else 
begin 

write_error( ’unknown  constant  type  *, token); 

end; 
end; 

procedure  operand^string (operand  :  operand_type;  var  token  :  token_type) ; 
var 

offset_string  :  token_type; 
begin 

token  blank_token; 
token  operand. id; 

if  (operand. index  <>  blank_token)  then 
begin 

if  operand. off set  <>  0  then 
begin 

str_integer  (operand. of fset , of fset__string) ; 
add_char_to_string  (token,  ’ [ ' ) ; 
concat  (token,  operand . index) ; 
add_char__to_string  (token,  *  +  '); 
concat  (token,  offset_string) ; 
add_char_to_string  (token,  MM 
end 
else 
begin 

add_char_to_string  (token,  '  [*); 
concat  (token,  operand . index) ; 
add_char_to_string  (token,  MM 


end 
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end 

else  if  operand -offset  <>  0  then 
begin 

str_integer (operand. offset, off set_string) ; 
add_char_to_string  (token,  • [•); 
concat  (token,  offset_string) ; 
add_char_to_string  (token,  MM 
end 

end;  (  of  operand_string  > 

procedure  check_operand_type  (operand  :  operand_type;  symbol_type.:longint) ; 
begin 

if  operand. id_type  -  real_constant_symbol_type  then  operand. id^type 

re  a l_syrobo l_t ype ; 

if  operand. id_t ype  *  integer_constant_symbol_type  then  operand. id_t ype 

integer_syrabol_type; 

if  operand. id_type  <>  syrabol_type  then 

write_error ( 'type  mismatch  :  ’ , operand. id) 

end;  (  of  check_operand_type  > 

procedure  reset_stack_pointer; 
begin 

»tack_po inter  dataram_address_limit; 

end;  (  of  reset_3tackjpointer  } 

procedure  free_*tack_operand; 
begin 

atack_pointer  stackjpointer  +  1; 

end;  (  of  increment_stackjpo inter  } 

procedure  decreraent_stack_pointer; 
begin 

stack_po inter  :«  stack_po inter  -  1; 
end;  {  of  decreraent_stack_pointer  l 

procedure  assign_temp_variable (var  variable  :  token_type); 
var 

temp_string  :  token_type; 

begin 

terap_string  blanket oken; 

str_integer  (next_temp_variable_locat ion, variable) ; 
terap_string[l]  i- 
concat (terap_string  .variable); 
variable  temp_string; 
end; 

procedure  reset_operand(var  operand  :  operand_type) ; 
begin 

operand. id  blank^token; 
operand. index  :»  blanJc_token; 
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operand. offset  0; 
operand. ld_addr ess  0; 

end;  {  of  reset  operand  } 


procedure  siraplify_type(var  symbol_type: longint) ; 
begin 

case  symbol^ type  of 

integer_constant_symbol_type:  symbol_type 
real_constant_syrabol_type :  symbol_type 

boolean_constant_symbol_type:  syrabol_type 
real_array_symbol_type :  symbol_type  s- 

integer_array_symbol_type:  symbol_type  :- 

boolean_array_syrabol_type :  symbol_type 

end; 

end;  {  simplified_data_type  > 


integer_symbol__type; 
r ea l_symbol_type ; 
boolean_symbol_type; 
r ea l_symbo l_type ; 
int ege r_symbo l_t ype ; 
boolean_symbol_type; 


procedure  assign_durarayj3araraeter  (var  parameter ; operand_t ype) ; 
begin 

reset_operand (parameter) ; 
parameter. id  blank_token; 
parameter. id [1]  *#*; 

end;  {  of  assign_duramy_parameter  } 

procedure  assign_parameter (var  parameter:  operand_type;parameter_type: longint) ; 

var  integer_address  j  longint;  (  used  to  increment  the  datarare  address  for  integer  ) 

begin 

reset_operand (parameter) ; 
parameter. id_type  pararaeter_type; 

str_integer  (next_dataram_locat ion, parameter . id) ; 
if  parameter. id_t ype  -  integer_symbol_type  then 
integer^address  next_dataram_location; 

temp_token  blank_token; 
temp_token[l]  :-  '4*; 
concat  (temp_token,  parameter .id) ; 
parameter. id  :-  terap_token 
end;  {  of  assign_parameter  ) 

procedure  as signet empjparameter (var  parameter:  operand_type; 

parameter_type  :  longint); 

begin 

reset_operand (parameter) ; 
parameter . id_type  :-  parameter_type; 

str_ integer  (next_temp_variable_location, parameter . id) ; 

temp_token  blank_token; 

temp_token(ll 

concat  (temp_token,  parameter . id) ; 
parameter. id  temp_token 
end;  (  of  assign_temp_parameter  ) 

procedure  assign_parametric_operand (var  parameter:  operand_type) ; 
begin 
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reset_operand (parameter) ; 

parameter. id_addr ess  next_dataram_location; 

str_integer  (parameter . id_addr ess, parameter .  id)  ; 
terop_token  blank_token; 
temp_token(l)  *#'; 
concat  (temp_token,  parameter .id) ; 
parameter. id  terap_token 
end;  C  of  assign_pararaetric_operand  ) 


procedure  fetch_expression(var  F,R,S  :  operand_type; 

expression  :  expres3ion_pointer) ; 


begin 

if  expression* .  left* . id  -  blank__token  then 
R  s-  zero_operand 
else 
begin 

R.id  expression*. left*. id; 

R. index  expression*. left* .index; 

R. off set  s-  expre ssion*. left*. offset ; 

R. id_type  expression*. left*. id_type; 

end; 

if  expression*. id  -  blank_token  then 
S  zero_operand 
else 
begin 

S.  id  express ion*. id; 

S. index  expression*. index; 

S. offset  expression*. off set; 

S.id_ type  :«•  expression*. id_type; 
end; 

F.id  expression*. left*. up*. id; 

F. index  expression*. left*. up*. index; 

F. offset  expression*. left*. up*. offset; 
F.id_type  expression*. left* .up* . id_type; 

if  (F.idtU  -  ’%')  then 
begin 

assign_temp_parameter  (F,F.  id__type)  ; 
expression*. left*. up*. id  F.id; 
end; 

end;  {  of  fetch_expression  ) 


procedure  store_expression(var  F,R,S  ;  operand_type;  expression  :  expre ssion_pointer) 
begin 

expression*. left*. id  R.id; 

expression*. left*. index  R. index; 

expression*. left*. offset  t-  R. offset; 
expression*.left*.id_type  R.id_type; 
expression*. id  :»  S.id; 
expre ssion*. index  S. index; 
expression* .offset  t-  S.offset; 
expression*.id_type  S.id_type; 
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expression*. left*. up*. id  s-  F.id; 
expression*. left*. up*. index  F. index; 
expression*. left*. up*. off set  F.offset; 

expression*.left*.up*.id_type  F.id_type; 
end;  {  of  store_expression  ) . 
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File:  VALR.PAS 

program  valr  (input,  output); 


const  max_token_length  -  50; 

type  tokentype  -  array  [1. .50]  of  char; 

var 


x,i  :  integer; 
r  :  real; 

string  :  tokentype; 
valrout,  valrin  :  text; 


procedure  val_real  (charstring  :  tokentype;  var  real_number  :  real; 

var  errorjLnteger  :  integer) ; 


label  1; 


var  i»j  s  integer; 

exponent  :  integer; 

x  :  real; 

sign  :  integer; 

exponent_to ken, token  :  tokentype; 

{  Discarding  leading  zero  ) 

Procedure  Delete_leading_zero  (var  token  :  tokentype) ; 

var  i,j  :  integer; 

begin 

i  It 

while  i  <-  max_token_length  do 
begin 

if  (token fi]  -  *0*)  then 
begin 

for  j  :■  i  to  max_token_length-l  do 
begin 

token(j)  token(j+l]; 

end; 

token  [raax_jtoken_length] 

end 

else 

if  (token(i)  -  »  +  *)  or  (tokenfi]  -  »-')  then 
i  i  +  1 

else 

i  max_token_length  +1; 

end; 

end; 


{  This  function  converts  a  packed  array  of  character  that  represents  an  integer 
to  real  number  ) 


function  char_integer_to_real (token  :  tokentype);  real; 


label  1; 
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var  i  :  integer; 

x, power  ;  real; 
begin 

x  s-  0; 

(check  for  valid  integer) 

for  i  ;«  1  to  raax_token_length  do 

begin 

if  (token [i]  <>  *  *)  and  (token [i]  <>  '+')  and  (token (i]  <>  *-•)  then 
if  ( (ord (token (il )  <  48)  or  (ord(token(i] )  >  57))  then 
begin 

error_integer  9999;  {  for  error  checking  -  T.F.) 

goto  1 
end; 

end; 

i  max_token_length; 

while  (i  >  0)  and  (token (i)  -  *  ')  do  i  i-1; 

if  (i  -  0)  then  goto  1;  (if  token  -  blank  token  } 

x  ord (token (i| ) -48; 

power  1; 
i  s-  i-1; 

while  (i  >  0)  do 
begin 

if  ( (ord(tokenti) )  >-  48)  and  (ord(token (i) )  <-  57))  then 
begin 

power  power* 10.0; 

x  ;•  x  +  (ord (token [i] ) -48) *power; 
end; 

if  token [i]  -  then  x  -x; 
i  i-1; 
end; 

1;  char__integer_to_real  x; 

end;  (  of  char  integer  to  real  conversion  } 


{  beginning  of  the  function  token  to  real  converter  ) 

begin 

token  charstring; 
exponent  : -  0 ; 

error_integer  :«  0;  (if  stays  0  then  no  error  occurred  -  T.F.  } 
delete_leading_zero  (token) ; 

(  Detecting  whether  digit  left  of  decimal  point  is  0  ) 

if  (token [1]  -  )  or  ((token (2)  -  ♦.')  and 


not  (token(l)  in  [,1,..,9*]))  then 
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{  +  or  -  sign  could  have  preceded  the  decimal  point  l 
begin 

if  token {1]  -  then  i  2 
else  i  3; 

while  token til  -  *0*  do 
begin 

exponent  exponent-1; 
i  i  +  1: 
end 

end; 

{  Detecting  decimal  point  > 

i  1; 

while  (i  <-  max_token— length)  do 
begin 

if  token(i]  •  ’ . ’  then 
begin 

for  j  i  to  max_token_length-l  do 
token! j]  *"  token! j+1]; 
token (max_token_length]  s-  '  * ; 

i  max_token_length: 

end 

else 

if  (token til  -  '«’}  or  (token (i]  -  'E')  then 
i  s-  raax_token_length 
else 

if  (ord (token {il )  >-  48)  and  (ord (token (il )  <-  57)  then 
exponent  exponent +1;  * 

i  i  +  1; 

end; 

{  check  for  exponential  notation  *e’  or  ’E’  ) 

i  1; 

while  (i  <-  max_token_length)  do 
begin 

if  (token til  -  'e')  or  (token ti]  -  ’E’)  then 
begin 

token !i]  »  *; 

for  j  1  to  raax_token_length  do 
begin 

exponent_token [ j]  '  f; 

end; 

for  j  j-  i+1  to  max_token__length  do 
begin 
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exponent_token[ j]  token (j]; 
token [j]  i-  *  *; 

end; 

x  char_integer_to_real(exponent_token) ; 
writeln (x) ; 

exponent  s-  exponent  +  round (x); 

i  max_token_length  +1; 

end 

else 

i  1  +  1; 

end; 

x  s-  char_integer_to_real (token) ; 
while  abs(x)  >■  1  do  x  x/10; 

if  exponent  >  0  then 

for  1  :>  1  to  exponent  do  x  :»■  x*10.0; 
if  exponent  <  0  then 

for  i  -1  downto  exponent  do  x  x/10.0; 

1:  real__nuinber  x; 

end; 


begin 

rewrite  (valrout ,  * ; $ : valrout • ) ; 
reset  (valrin,  *:$: valrin’ ) ; 
while  not  eof (valrin)  do 
begin 

for  x  1  to  50  do 
begin 

string (x]  '  '; 

if  not  eof (valrin)  and  not  eoln (valrin)  then 
read  (valrin,  stringtx)); 

end; 

readln  (valrin) ; 
val_real  (string,  r,  i) ; 
if  i  -  0  then  writeln  (valrout,  r:20:IQ) 
else  writeln  (valrout,  'i:',  i) 
end; 


end 
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C.  Floating-Point  Loader  source  code 


/* 

Copyright  1990 

Georgia  Tech  Research  Corporation 
Centennial  Research  Building 
Atlanta,  GA  30332 
*/ 


♦include  <stdio.h> 
♦include  <string.h> 
♦include  <stdlib.h> 
♦include  <host.h> 


♦define  DATA_PORT  OxOcOOO 
♦define  STATUS_PORT  OxOeOOO 


unsigned  short  number_error; 
char  *value; 
unsigned  long  base; 
unsigned  long  limit; 
unsigned  long  type; 


'*  microcode  field (s)  */ 


unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

unsigned 

short 

prograra_counter; 
am2910_opcode; 
branch__address; 
br anch_opcode ; 
wr ite_opcode ; 
dsel; 

read_opcode; 
enf Joar; 

14; 

i3; 

mc325; 

af; 

ar ; 

as; 

msw; 

ia2; 

ial; 

iaO; 

aif ; 


unsigned  short  air; 
unsigned  short  ais; 

void  stop_processor(  void  ) 

{ 

unsigned  short  temporary; 

temporary  -  0; 

poke(  base  +  STATUS_PORT,  (temporary,  sizeof<  temporary  )  ); 
peek(  base  +  STATUSJPORT,  (temporary,  sizeoff  temporary  )  ); 
if  (  (  temporary  (  4  )  i-  4  ) 

{ 

number_er ror ++ ; 

printf{  "ERROR:  unable  to  stop  the  processor\n"  ); 

> 

}  /*  stop_processor  */ 

void  start_processor(  void  ) 

< 

unsigned  short  temporary; 

temporary  -  1; 

poke(  base  +  STATUS_PORT,  (temporary,  sizeof(  temporary  )  ); 
peek(  base  +  STATUS__PORT,  (temporary,  sizeof(  temporary  )  ); 
if  {  (  temporary  (  4  )  —  4  ) 

{ 

nuraber_error++ ; 

printf(  "ERROR:  unable  to  start  the  processor\n"  ); 

) 

)  /*  start_processor  */ 

void  reset_processor (  void  ) 

stop_processor (  ); 
start_processor (  ) ; 

>  /*  reset_processor  */ 

int  rfi(  void  ) 

{ 

register  unsigned  short  count; 
unsigned  short  temporary; 

for  (  count  -  0;  count  !<*  1000;  count++  ) 

i 

peek{  base  +  STATUS_PORT,  (temporary,  sizeof (  temporary  )  ) 
if  {  (  temporary  (  2  )  —  2  ) 


return (  TRUE  ) ; 
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) 

number_error++; 

print f ( "ERROR :  processor  RFI  not  responding  after  1000  counts\n"); 

return (  FALSE  ) ; 

}  /*  rfi  */ 


void  send(  unsigned  short  ‘buffer  ) 

{ 

if  (  rfi<  )  ) 

poke(  base  +  DATA_PORT,  buffer,  sizeof {  ‘buffer  )  ); 

}  /*  send  */ 


int  dav(  void  ) 

{ 

register  unsigned  short  count; 
unsigned  short  temporary; 


for  (  count  —  0;  count  !•»  1000;  count++  ) 

{ 

peek  (  base  +  STATUS_PORT,  ^temporary,  sizeof (  temporary  )  >; 
if  <  <  temporary  i  1  )  —  1  ) 
return (  TRUE  ); 


) 


number_err or ++ ; 

printf(  ♦'ERROR:  processor  DAV  not  responding  after  1000  counts\n**  ); 

return (  FALSE  ) ; 

}  /*  dav  */ 


void  receive (  unsigned  short  ‘buffer  ) 

{ 

if  <  dav(  )  ) 

peek<  base  +  DATA_PORT,  buffer,  sizeof (  ‘buffer  )  ); 

}  /*  receive  */ 


void  reset_raicrocode_field{  void  ) 

( 

ara2910_opcode  -  0x0  e; 
branch_address  -  0; 
branch_opcode  -  0; 
write_opcode  -  0; 
dsel  -  0; 
read_opcode  -  0; 
enf  bar  -0; 
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14  -  0; 

13  -  0; 
mc325  -  0; 
af  -  0; 
ar  -  1; 
as  -  1; 
rasw  -  0; 
ia2  -  0; 
ial  -  0; 
laO  -  0; 
aif  -  0; 
air  -  0; 
ais  -  0; 

}  /*  reset_microcode  */ 


/*  pack  the  instruction  fields  and  down  load  them  to  the  processor  */ 
void  load_code(  void  ) 

{ 

unsigned  short  microcode{6] ; 
unsigned  short  index;  > 
unsigned  short  offset; 
unsigned  short  temporary; 

microcode  [  0  ]  -  (msw«15) 

+  (ia2«14) 

+  (ial«13) 

+  (ia0«12) 

+  (aif«8) 

+  (air«4) 

+  ais; 

microcode [11  -  as; 
microcode [2]  -  ar; 
microcode [3]  -  af; 
microcode [ 4 ]  -  (branch_opcode<<12) 

+  (write_opcode«9) 

+  dsel 

+  (read_opcode«6) 

+  (enf_bar«5) 

+  (i4«4) 

+  <i3«3) 

+  mc325; 

microcode  [5]  -  (ara2910__opcode«12) 

+  branch_address; 

for  (  index  -  0;  index  <«5;  index++  ) 

offset  »  (index«13)  +  (program_counter<<l)  ; 

poke<  base  +  offset,  Smicrocode [index] ,  sizeof(  microcode [index]  )  ); 
peek(  base  +  offset,  ^temporary,  sizeof (  temporary  )  ); 
if  (  microcode [index]  !-  temporary  ) 
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< 

number_error++; 

printf<  "ERROR:  instruction  memory  loading  failed :\n"  ); 
printf<  H  write  %04x  \n",  microcode [index]  ); 
print f (  "  read  %04x  \n",  temporary  ) ; 

} 

)  /*  load_code  */ 


/*  generate  codes  for  the  processor  to  receive  data  from  the  host  */ 
■  void  generate_receive (  unsigned  short  address  ) 

< 

reset_microcode__field(  ); 
af  -  address; 
if  <  address  —  1  ) 
i 

as  -  0; 

ar  -  0; 

> 

msw  -  1; 
do 
{ 

write_opcode  -  0; 
am2910_opcode  -  OxOe; 
load_code (  ) : 

program_counter  -  program_counter  +  1; 

am2910_opcode  -  3; 

branch^address  -  program_counter; 

branch_opcode  -  2; 

write_opcode  -  2; 

load_code (  ); 

prograra_counter  -  program_counter  +  1; 
msw  -  msw  -  1; 

) 

while  (  msw  !-  -1  ); 
reset_microcode__field  (  ); 

)  /*  generate_receive  */ 


/*  generate  codes  for  the  processor  to  send  data  from  the  host  */ 
void  generate_send {  unsigned  short  address  ) 

< 

reset_microcode_f ield {  ) ; 
as  -  address; 
ar  -  address; 
if  (  address  —  0  ) 

{ 

af  -  1; 

] 

msw  -  1; 
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do 

{ 

read_opcode  -  0; 
ara2910__opcode  -  OxOe; 
load_code (  ) ; 

program_counter  -  program_counter  +  1; 

am2910_opcode  -  3; 

branch_address  •  program^counter ; 

branch_opcode  -  3; 

read_opcode  -  2: 

load_code(  ); 

prograra_counter  -  program_counter  +  1; 
rasw  -  msw  -  1; 

> 

while  (  rasw  1-  -1  ); 
reset_microcode_f ield (  ) ; 
i  /*  generate_send  */ 


/*  load  the  procedure  that  will  fetch  constants  from  the  host  */ 
void  load_pct{  char  *path  ) 

{ 

FILS  *file; 
char  line [256]; 

unsigned  short  address,  msw,  lsw; 

if  {  (  file  -  fopen (  path,  **r"  )  )  —  NULL  ) 
t 

printf<  "ERROR:  unable  to  open  for  read  %s\n",  path 
exit (  -1  ),* 

> 

stop_processor (  ); 

program_counter  -  0; 
reset _raicrocode_f ield {  > ; 
load^code (  ) ; 

prograra_counter  -  program_counter  +  1; 
load__code {  ) ; 

program_counter  -  program__counter  +  1; 

while  (  fgets (  line,  sizeof(  line  ),  file  )  !-  NULL  ) 

{ 

if  <  line [  0  ]  —  ) 

continue; 

if  (  sscanf(  line,  "v  %d  %d  %d\n",  saddress,  4msw, 

{ 

generate_receive (  address  ); 
generate_send {  address  ); 

) 


filsw  )  --  3  ) 
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> 

ara2910_opcode  -  3; 
branch_opcode  -  0x0c; 
branch_address  -  prograra_counter; 
load_coda (  ) ; 

f close (  file  ); 

}  /*  load_pct  */ 


/*  this  procedure  is  used  to  load  the  constants  to  the  amd  floating  point  processor  */ 
void  load_hct (  char  *path  > 
i 

FILE  *file; 
char  line [256]; 

unsigned  short  address,  msw,  lsv; 
unsigned  short  temporary; 

if  (  (  file  -  fopen<  path,  "r"  )  )  —  NULL  ) 

( 

printf (  "ERROR:  unable  to  open  for  read  ’ts'Xn",  path  ); 
exit (  -1  ); 

) 

start_processor  (  )  ,* 

while  (  fgets(  line,  sizeoft  line  ),  file  )  !-  NULL  ) 

i 

if  (  linet  0  3  —  ) 

continue; 

if  (  sscanf (  line,  "v  %d  %d  %d\n",  ^address,  Smsw,  Slsw  )  —  3  ) 

{ 

send (  *msw  ) ; 
send(  4lsw  ); 

receive (  ^temporary  ) ; 
if  (  temporary  !-  msw  ) 

< 

number_error++; 

printf <  "ERROR:  constant  load  failed:  msw\n"  ); 

} 

receive (  itemporary  ); 
if  (  temporary  !-  lsw  ) 

{ 

number_error++; 

printf (  "ERROR:  constant  load  failed:  lsw\n"  ); 


) 
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) 

fclose(  file  ); 
)  /*  load_hct  */ 


/*  this  program  is  used  to  load  program  to  the  arad  floating  point  processor  */ 
void  load_fpp(  char  *path  ) 

{ 

FILE  *file; 
char  line  1256]; 
unsigned  short  offset; 
unsigned  short  temporary; 

stop_processor (  ); 

if  {  (  file  -  f open {  path,  "r"  )  )  —  NULL  ) 

{ 

printft  "ERROR:  unable  to  open  for  read  %s\n",  path  ); 
exit {  -1  ); 

> 

while  (  f gets (  line,  sizeof(  line  ),  file  )  !-  NULL  ) 

{ 

if  (  line [ 0  ]  —  ) 

continue; 

if  (  sscanft  line,  "b  %d  %d\n",  4program_counter,  4branch_address  )  —  2  ) 

{ 

temporary  -  5; 

offset  -  (temporary<<13)  +  (program_counter«l)  ; 
peek{  base  +  offset,  4temporary,  sizeoft  temporary  )  ); 
am2910_opcode  -  (temporary»12) ; 

temporary  -  (am2910_opcode<<12 )  +  branch_address; 
poket  base  +  offset,  ^temporary,  sizeoft  temporary  )  ); 

> 

if  <  sscanf (  line,  "c  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  %d  \n”, 
4program__counter,  Sam2910_opcode,  4branch__address,  4branch_opcode, 

4vrite_opcode, 4dsel, 4read_opcode, 4enf_bar, 4i4, 4i3, 4mc325, 

4af , 4ar, (as, 4msw, 4ia2, 4ial, 4ia0, 4aif, 4air, 4ais)  —21  ) 

load_code {  ) ; 

) 

f closet  file  ); 

}  /*  load_fpp  */ 


♦define  PROGRAM  argument [  0  } 
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♦define  NAME  argument [  1  ] 
♦define  PATH  argument [  2  ] 


void  main<  int  number_argument,  char  *argument[  ]  ) 

{ 

char  patht  256  ]; 

initialize_environment  (  " :  HWffi :  environment”  ); 

if  <  nuraber_arguraent  !-  3  ) 

{ 

fprintf(  stderr,  "usage:  %s  <narae>  <path>\n",  PROGRAM  ); 
exit (  0  ); 

if  (  (  value  -  getenv  <  NAME  )  )  —  NULL  ) 

{ 

fprintf(  stdout,  "ERROR :  ’  %s'  not  found  in  environment^",  NAME  ); 
exit (  -1  ); 

if  <  sscanf (  value,  "%lx; %lx; %lx; ",  fibase,  4limit,  ttype  )  !-  3  ) 

{ 

fprintf (  stdout,  "ERROR:  unable  to  parse  *%s  -  %s’\n",  NAME,  value  ); 
exit (  -1  >; 


number_error  -  0; 
resetprocessor {  ) ; 

printf(  "loading  %s\n",  NAME  ); 
strcpy{  path,  PATH  ); 
strcat(  path,  ".hct"  ); 
load_pct (  path  ) ; 

printf (  "loading  %s  data\n",  PATH  ); 
strcpy(  path,  PATH  ); 
strcat(  path,  ".hct"  ); 
load_hct(  path  ); 

printf <  "loading  %s  code\n”,  PATH  ); 
strcpy{  path,  PATH  ); 
strcat(  path,  ".fpp"  ); 
load_f pp (  path  ) ; 

printf (  "starting  %s\n",  NAME  ); 
startprocessor (  ); 

if  (  number_error  !-  0  ) 

printf (  "number  error (s)  -  %d\n'\  number_error  ); 


D 


Crossbar/Sequencer  Compiler  source  code 


Copyright  1990 

Georgia  Tech  Research  Corporation 
Centennial  Research  Building 
Atlanta,  GA  30332 


{  iRMX  PFP  Crossbar /Sequencer  Compiler  VI. 0  } 

{  Compatible  with  the  GT-XB/2  and  RMXII  only.  .  > 

(  > 

(  > 

{  Key  Words  :  LOOP,  CYCLE  1 

{  p {receiver ) {,p (receiver ) ]  :«  p (sender) . (repeat  factor)  ) 

(  comments  contained  between  []  ) 

i  1 

{  BootLoadable  OMF286  Absolute  Code  is  generated  for  the  ) 


sequencer  { sequencer. bl)  and  crossbar  (crossbar. bl)  memories.  ) 

> 

OMF86  and  RMXI  by  :  T.  S.  Floyd  > 


{  Date  s  April  22,  1988  Version  3.0  > 

{  OMF286  and  RMXII  by  :  T.  R.  Collins  4  S.  R.  Wachtel  } 

(  Date  :  February  22,  1990  Version  1.0 

t  > 

- - - 

MODULE  xbc; 


PUBLIC  UDI; 
type 

date_time_type  -  record 

system_time  :  longint; 
date  :  array(0..7J  of  char; 
time  :  array [0.. 7]  of  char; 

end; 

procedure  dqdecodetime (var  datetime  :  date_time_type;  var  except  :  integer) 

PUBLIC  RANDOMIO; 

procedure  setrandom(var  f:  bytes); 
procedure  seekread(var  f;  bytes;  r:  longint); 
procedure  seekwrite ( var  f:  bytes;  r:  longint); 
function  position(var  f:  bytes):  longint; 
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PUBLIC  xbc; 


PROGRAM  xbc ( input , output ) ; 


const 


start_lower  - 

61H; 

convert_upper  - 

2  OH; 

eonvert^numb  - 

3  OH; 

cr  - 

ODH; 

If  - 

OAH; 

space  - 

20H; 

max_coram  - 

16; 

max_proc_nurab  - 

31; 

max_digits  - 

2; 

max__errors  - 

30; 

bits_in_word  - 

16; 

max_x_bus  - 

15; 

min_y_bus  - 

16; 

fourth_xbar  - 

7; 

max_step  - 

1024; 

name_size  - 

20; 

end_raar)c  - 

32; 

null  - 

OOh; 

type 


byte  -  0 . .255; 

bus_list  -  array  [0 . .raax_proc_numb]  of  char; 

error_array  -  array  tl . .max^errors]  of  integer; 

mat_array  -  array  (0 . ,max_x_bus,rain_y_bus . .max_proc_numb]  of  integer; 

proc_array  -  array  [1.  .max_cojwnf  0.  .max_proc_numb]  of  integer; 

repeat_array  -  array  [1.  .max_coratt]  of  integer; 

word_array  -  array  [0 .  .raax_procjmimb]  of  integer; 

digit_store  -  array  [1 . .max_digits]  of  char; 

proc_jLnfo  -  record 

repeat_f actor  :  repeat_array; 
receiver  ;  proc_array; 

sender  :  proc_array; 


end; 

transfer  -  record 

count  ;  integer; 
sender  :  repeat_array; 

receiver  :  repeat_array: 

end; 


file_name  ;  packed  array [1 . ,name_3ize]  of  char; 
seq_abs, 

xbar_abs  :  file  of  byte; 

input_file, 

addr_setup, 
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eof_flag, 

stop_proc, 

jump_flag, 

gen_addr , 

gen^setup  : 

cornrc_count, 

cycle_number 

step_number, 

jurap_n  umber, 

jurap_cycle  : 
check_aura  : 
clear_proc, 
processor  : 
error_log  : 
clearer  an, 

xtox, 

xtoy, 
ytox. 


text; 


boolean; 


integer; 

byte; 

proc_info; 

error_array; 


ytoy  :  transfer; 

xbar_bus  s  bus_list; 
clear_raatrix, 
xbarjnatrix  i  mat_array; 
num_abs_seq_sets_output  :  integer; 


num_abs_xbar_sets_output  :  integer; 


PROCEDURE  open_files; 

var 

input_char  :  char ; 
kount  :  integer; 

begin 

writeln ( ' iRMXII  PFP  Crosabar/Sequencer  Compiler  VI. O’) 
writeln; 

for  kount  i»  1  to  name_size  do 
file_name [kount] 

write (’Enter  name  of  file  with  compiler  input  - 

kount  : -  0 ; 

repeat 

read(input_char) ; 
kount  kount  +1; 
file_name [kount]  input_char; 
until  (  ord(input_char)  -  end_mark  ); 
filename  [kount  ]  chr(null); 


writeln; 
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write ('Do  you  want  to  generate  the  setup  file,  setup.dat  (y/n)?*); 
readln(input_char) ; 

if  input_char  in  ['Y'.'yM  then  gen_setup  true 
else  gen_setup  false; 

writeln; 

write ('Do  you  want  to  generate  the  address  file,  address.dat  (y/n)?'); 
readln  (input_char)  ; 

if  input_char  in  [,Y,,,y'l  then  gen_addr  s-  true 
else  gen_addr  false; 

reset (input_file, file_narae) ; 

setrandora(seq_abs) ; 
rewrite (seq_abs, ' SEQUENCER. BL' ) ; 

set  random  (xbar__abs)  ; 
rewrite (xbar^abs , ’ CROSSBAR . BL ' ) ; 
if  gen_setup  then 

rewrite ( setup, • SETUP . DAT  * ) ; 
if  gen_addr  then  begin 

rewrite (addr_setup, 'ADDRESS.DAT') ; 
writeln (addr_set up, 'Next  Addresses'); 
writeln (addr_se tup) ; 
writeln (addr_setup, 

*  Cycle  Crossbar  Address  Sequencer  Address* ) ; 
writeln ( a ddr_setup) ; 

end; 

end;  {  PROCEDURE  open_files  } 


FUNCTION  power (  expon,  base  :  integer  )  :  integer; 

begin 

if  expon  >-l  then 

power  power (  expon-1.  base  )  *  base 

else 

power  1; 

end;  {  FUNCTION  power  } 


PROCEDURE  write_byte(  which_one:  char;  input_value:  byte  ); 
begin 


if  (  which_one  -  ,'S'  ) 
then 


begin 
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seq_abs*  input_value; 
put {  seq_abs  ) ; 


xbar_ab3'“  input_value; 
put (  xbar_abs  )? 


end;  {  PROCEDURE  write_byte 


PROCEDURE  initialize^ output_files; 


i  :  integer? 

date_time  :  date_time_type? 
except  :  integer; 

begin 

date_tirae.systera_time  0;  {  Request  new  time  and  decode  ) 

dqdecodetime ( dat e_t irae ,  except ) ; 

num_abs_seq-sets_output  0; 


write_byte {  ♦ S  ’ , 

0A2H  )? 

{  A2H  -  boot 

write_byte (  'S', 

00H  );  (total  space} 

write_byte<  ’S', 

00H  ) ; 

write_byte(  'S', 

00H  ) ; 

write_byte<  'S', 

00H  ); 

for  i  0  to  7 

do 

write_byte(  'S 

*,  ord (date_time. date 

for  i  :■  0  to  7 

do 

write_byte (  *S 

*,  ord (date_tirae. time 

write_byte (  'S', 

ord  <  ’  i 

)  );  I 

write__byte(  'S', 

ord(  'R 

)  ) ; 

write_byte {  'S', 

ord(  'M 

)  ) ; 

write_byte{  'S', 

ord  (  'X 

)  >; 

write_byte (  'S', 

ord  (  * 

)  ) ; 

write_byte (  'S', 

ord(  'P 

)  ) ; 

write_byte(  ’S', 

ord (  *  F 

)  ); 

write_byte(  'S', 

ord (  'P 

)  ) ; 

write_byte (  'S', 

ord  (  * 

)  ) : 

write_byte(  ’S', 

ord(  'C 

)  ); 

write_byte {  'S', 

ord (  ' r 

)  >; 

write_byte(  'S', 

ord{  'o 

)  ); 
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vrite_byte ( 

'S', 

ord( 

*a' 

) 

>; 

vrite_byte ( 

’S’, 

ord< 

's' 

) 

); 

write_byte ( 

's*. 

ord  ( 

*bf 

) 

) ; 

write_byte ( 

*S\ 

ord  ( 

'a* 

) 

) ; 

write_byte ( 

's'. 

ord( 

*r* 

) 

) ; 

vrite_byte ( 

'S', 

ord  ( 

'/' 

) 

)  -* 

write_byte ( 

’S\ 

ord  ( 

'S' 

) 

) ; 

write_byta ( 

’S’, 

ord( 

*9' 

) 

) ; 

write^byte ( 

fs* , 

ord  { 

’q* 

) 

) ; 

write^byte  < 

’S', 

ord( 

*u* 

) 

) ; 

write_byte ( 

'S', 

ord{ 

*e' 

) 

) ; 

vrite_byte ( 

'S', 

ord{ 

*n' 

) 

) ; 

write_byte( 

'S', 

ord( 

•c’ 

) 

); 

write_byte ( 

'S', 

ord( 

»e' 

) 

); 

write_byte ( 

'S', 

ord{ 

'X' 

) 

) ; 

write_byte { 

'S', 

ord( 

) 

) ; 

write_byte ( 

'S', 

ord( 

'C' 

) 

) ; 

write^byte { 

'S', 

ord( 

'o' 

) 

); 

write_byte ( 

'S', 

ord( 

'm' 

) 

)  t 

write_byte ( 

'S', 

ord( 

’P' 

) 

): 

write_byte ( 

'S', 

ord( 

'V 

) 

): 

write  Jsyte ( 

'S', 

ord( 

) 

) ; 

writejbyte ( 

'S', 

ord( 

•e* 

) 

); 

write_byte ( 

* S' , 

ord  ( 

»r» 

) 

) ; 

write_byte ( 

'S', 

ord( 

• 

) 

); 

write_byte { 

'S', 

ord  ( 

•v* 

) 

); 

writejbyte ( 

'S', 

ord  ( 

*lf 

) 

); 

write_byte ( 

'S', 

ord( 

) 

); 

write_byte< 

'S', 

ord( 

'O’ 

write_byte ( 

'S', 

00H  1 

; 

{GDT} 

write_byte ( 

'S', 

00H  ] 

; 

write  Jsyte ( 

'S', 

00H  ] 

: 

writejayte ( 

'S', 

00H  ] 

; 

writejbyte { 

'S'  , 

00H  ] 

t 

write_byte ( 

'S', 

00H  ] 

write  Jayte ( 

'S', 

00H  ); 

{IDT} 

write_byte ( 

'S', 

00H 

; 

write_byte ( 

'S', 

00H 

; 

write_byte ( 

'S', 

00H  )  ; 

writejbyte ( 

'S', 

OOH  ); 

write_byte  < 

'S', 

OOH 

; 

writejbyte ( 

'S', 

OOH 

; 

{TSS> 

write_byte ( 

'S'  , 

OOH 

' 

write_byte ( 

'S', 

96  ) 

(ABSTXT  Location} 

writejbyte ( 

'S'  , 

OOH 

; 

write  Jbyte ( 

'S', 

OOH 

write_byte ( 

•s'. 

OOH 

; 
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write_byte{  'S', 

00H  )  ; 

(DEBTXT  Location) 

write_byte(  'S', 

00H  ) ; 

write_byte{  'S', 

00H  ) ; 

write_byte<  'S', 

00H  ) ; 

write_byte{  'S', 

00H  )? 

{ENDTXT  Location  -  MUST  BE  DONE  LAST} 

write_byte (  'S’, 

OOH  )  ; 

write _byte (  'S', 

00H  ) ; 

write_byte{  ’S', 

OOH  ); 

write_byte {  'S', 

OOH  ); 

{Next  Partition) 

write_byte{  'S’, 

OOH  ) ; 

write_byte (  'S', 

OOH  ); 

writejsytet  'S', 

OOH  ); 

write_byte<  'S’, 

OOH  ) ; 

{Reserved} 

write_byte<  'S', 

OOH  ); 

write_byte<  'S', 

OOH  )  ; 

write_byte (  'S', 

OOH  ); 

write_byt*(  'S', 

OOH  )  ; 

{ABSTXT  Address) 

write_byte (  'S', 

OOH  ); 

write_byte(  'S', 

OOH  ); 

writejbyte (  'S', 

OOH  ) ; 

{ABSTXT  Length  -  MUST  BE  DONE  LAST) 

write^yte (  'S', 

OOH  ) ; 

nura_abs_xbar_sets_output  : 

-  0? 

write_byte<  'X', 

0A2H  ) ;  { 

A2H  -  boot  loadable  module  ) 

write_byte(  'X', 

OOH  );  {total  space} 

write_byte(  'X’f 

OOH  )  ; 

write_byte{  'X*, 

OOH  )  ; 

write__byte(  'X', 

OOH  ) ; 

for  i  0  to  7 

do 

write_byte(  'X 

ord (data_time« date [i] )  ); 

for  i  0  to  7 

do 

writejbyte {  'X 

:*,  ord(datejtime.tirae[i] )  ); 

writejbyte (  'X', 

ord{  *i' 

)  ) ;  {Creator} 

writejbyte {  'X', 

ord(  'R* 

)  ); 

write_byte(  'X', 

ord(  'M' 

)  ) ; 

write^yte  (  'X', 

ord (  'X' 

)  ); 

write^yte  (  ’  X ' , 

ord (  ’  * 

)  ).* 

writejbyte {  'X', 

ord (  *P' 

)  ) ; 

write _byte (  ' X ' , 

ord (  'F* 

)  ); 

writejbyte <  'X', 

.  ord (  'P' 

)  ); 
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write_byte  (  »X\ 

ord(  *  * 

) 

); 

write_byte<  ?XT, 

ord(  'C» 

) 

) ; 

write_bytet  *X', 

ordt  fr* 

) 

); 

write_byte(  'X*, 

ord{  ’o' 

) 

) ; 

write_byte{  fX*# 

ord(  *3* 

) 

); 

write_byte {  *X* , 

ordt  ’s’ 

) 

) ; 

write^byte (  '  X  • , 

ord<  »b' 

) 

>.* 

write_byte(  *Xr, 

ord (  * a  * 

> 

) ; 

write_byte (  'X* , 

ord(  'r* 

) 

); 

write_byte (  'X*. 

ord(  ’/* 

) 

); 

write_byte<  rX*, 

ord<  »S? 

) 

); 

write^byte (  'X', 

ord {  * e ' 

) 

); 

write_byte(  ’X’, 

ord  (  ’«*' 

) 

) ; 

write_Jaytet  ’X’, 

ordt  'u* 

) 

) ; 

write_byte{  'X\ 

ord<  re* 

) 

) ; 

writejaytet  'X*, 

ord{  'n' 

) 

); 

write_byte(  ’X*, 

ordt  *c’ 

) 

} ; 

write_byte(  fX\ 

ord (  * e  * 

) 

).* 

write_byte(  ’X’, 

ord(  ’r* 

) 

) ; 

write_byte(  ’X', 

ord(  *  ’ 

) 

) : 

write_byte{  'X*, 

ordt  *C* 

) 

); 

wrlte__byte{  'X*, 

ord{  *o* 

) 

) ; 

wr ite_byt e {  ’ X  * , 

ord{ 

) 

) ; 

write_byte{  ’X*, 

ordt  *p* 

) 

)  s 

write_byte(  ’X*# 

ord (  ’ i ’ 

) 

) ; 

write_byte<  'X*, 

ord (  '1T 

) 

); 

writejbytet  'X*, 

ordt  'e* 

) 

»; 

write_byte<  'X», 

ordt  *r ’ 

) 

) ; 

write_byte(  ’X*, 

ordt  '  ’ 

) 

) ; 

writebytet  *X’ , 

ordt  'V* 

) 

)  t 

write_byte{  'X*, 

ordt  ' 1 * 

) 

)  i 

write_byte{  fx\ 

ordt 

) 

) ; 

write_byte(  *X', 

ordt  ’O' 

) 

) ; 

wr ite_by te (  * X  *  , 

00H  ) ; 

{GDT} 

write_byte(  *X', 

00H  ); 

write_bytet  'X*, 

00H  )  ; 

write_byte<  fX’, 

00H  ); 

write_bytet  *X’, 

00H  )  ; 

write Jaytet  'X*. 

00H  >; 

write_byte{  *X\ 

00H  ) ; 

{IDT} 

write_bytet  ’X’, 

00H  ) ; 

write_byte(  ?X’, 

00H  ); 

write_bytet  ’X', 

OQH  ) ; 

write_byte (  ’X', 

00H  )  ; 

write_byte(  'X*, 

00H  )  ; 

write_byte(  'X', 

OOH  ); 

{ TSS } 

write_byte(  fX’» 

00H  ); 
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write_byte (  ’X* , 

96  ); 

(ABSTXT  Location) 

write_byte(  'X*, 

00H  ); 

write_byte(  *X*, 

00H  ) ; 

write_byte(  *X\ 

00H  ); 

write_byte(  ’X*, 

00H  ); 

(DEBTXT  Location) 

vrite_byte(  *X*, 

00H  ); 

write_byte(  'X*, 

00H  ); 

write_byte<  *X*, 

00H  ); 

write_byte(  ’Xf, 

00H  ) ; 

(ENDTXT  Location  -  MUST  BE  DONE  LAST) 

writejDyte(  'X*, 

00H  ); 

writejoytei  ’X’, 

00H  ); 

write_byte(  'X', 

00H  ); 

writeJoyte(  ’X’, 

00H  ) ; 

(Next  Partition) 

write_byte<  'X*, 

00H  )? 

write_byte{  ’X*, 

00H  ) ; 

write_byte<  'X’, 

00H  ); 

write_byte{  'X*, 

00H  ); 

(Reserved) 

writebytet  ♦X*. 

OOH  ); 

write_byte{  'X*, 

00H  ); 

write J>yte<  'X*, 

OOH  ); 

write_byte (  *X\ 

OOH  ) ; 

(ABSTXT  Address) 

write_byte (  'X*, 

OOH  ); 

write_byte(  rX*, 

OOH  ) ; 

write_byte(  'X*, 

OOH  ); 

(ABSTXT  Length  -  MUST  BE  DONE  LAST  ) 

write_byte(  'X*, 

OOH  ); 

end;  {  PROCEDURE  initialize_output_files  ) 


PROCEDURE  f inish_output_f lies ; 

const 

endtxt_offset  -  84; 
length_offset  -  99; 


type 

temporary_type  - 
record 

case  byte  of 

0:  (b:  array [0.. 31  of  byte?); 

1;  (i:  integer;); 

2;  <li:  longint; ) ; 

end; 


var 
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temporary:  teraporary_type; 

begin 

temporary. Xi  5-  position (seq_abs) ; 
write_byte ( ’S* ,  OFFH) ;  {checksum} 

aeekwrite (seq_abs, endtxt_of f set) ; 
wr ite_byte (* S temporary . b [ 0 ]) ; 
write_byte  <  *  S  * , temporary .  b  { 1 ) ) ; 
write_byte( *S’ , temporary. b {2]) ; 
write_byt e  <  *  S  * , temporary . b [ 3 ] ) ; 

aeekwrite  {aeq_abs,length_off set) ; 
temporary.!  nura_abs_seq_sets_output  *  16; 
vrite_byte ( ' S * , temporary . b  [  0  ] ) ; 
write_byte {'S’, temporary . b [ 1 ]) ; 

temporary. li  position (xbar_abs) ; 
write__byte  ( fX* ,  OFFH) ;  {checksum) 

seekvrite (xbar_abs, endtxt_offset) ; 
write^byteCX’.temporary.blO] ) ; 
wr ite^byt e { 1 X  * , temporary .  b  { 1 } ) ; 
write_byte(  *X* ,  temporary. b[2] ) ; 
write_byte ( ’Xf , temporary . b {3 1 ) ; 

seekwrite (xbar^abs, length_offset) ; 
temporary.!  nura_abs_xbar_sets_output  *  64; 
write^bytet  fX* , temporary .b(0] ) ; 
write_byte( *X' temporary. b{l) ) ; 

end;  {  PROCEDURE  finish__output_files  ) 


FUNCTION  read_char  :  char; 

var 

file_char  :  char; 

ascii  :  integer; 

begin 

eof_flag  false; 

read {input_f ile, file_char) ; 

if  eof (input_file)  then  begin 
eof_flag  :«  true; 
stop_proc  true; 

end 

else  begin 

stop_proc  false; 

ascii  ord  (file__char) ; 
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if  (  ascii  >-  start_lower  )  then 

file_char  s-  chr (ascii  -  convert_upper) ; 
read_char  file_char; 

end; 


end;  (  FUNCTION  read_char  } 


FUNCTION  convert_to_integer (  count  :  integer; 

storage  :  digit_store  )  s  integer; 

var 

temp_integer, 

index, 

i  :  integer; 


begin 

temp_integer  0; 
for  i  :■  0  to  (count  -  1)  do  begin 
index  count  -  i; 

temp  integer  (ord (storage [index] )  -  convert_numb) *power (i, 10) 

+  temp_integer; 

end; 

convert_to_integer  temp_integer; 
end;  (  FUNCTION  convert _to_integer  ] 


PROCEDURE  read_numb (  type_read  :  char;  var  file_numb  ;  integer  ); 

var 

test_char  ;  char; 
count, 

index  ;  integer; 
storage  :  digit_store; 

begin 

case  type_read  of 
'R'  ;  begin 

count  0; 
repeat 

read (input_file, test_char) 
if  eof <input_file)  then 
stop_proc  true 

else 

stop_proc  false; 


if  not  stop_proc  then 
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if  ( (test_char  in  and 

<(count+l)  <-  rcax_digits) )  then  begin 
storage [count+1]  test_char; 
count  count  +  1; 

end; 

until  (  (test_char  in  (*, *,* s '  ,chr( space) ] )  or  stop_proc  ); 
if  count  -  0  then  stop_proc  :»•  true; 
if  not  atop_proc  then 
begin 

file_numb  s-  convert_to_integer (  count,  storage  ) ; 
if  (  file_numb  >*•  <  raax_proc_nurab  +  l  )  )  then 
file_nurab  file_numb  -  (  max_proc_nurab  +  1  ) ; 

end; 

end; 

*S’  :  begin 

count  : -  0 ; 
repeat 

read (input__file, test^char ) ; 
if  eof (input_file)  then 
eof^flag  true 

else 

eof_flag  false; 

if  < (test_char  in  and 

((count+1)  <-  raax_digits))  then  begin 
storage t count -M]  test_char; 

count  count  +  1; 

end; 

until  (  <test_char  in  chr (space) ] )  ); 

if  count  -  0  then  stop_proc  true; 
if  not  stop^proc  then  begin 

file_numb  convert_to_integer (  count,  storage  ); 
if  (  file_numb  >-  (  maxjproc_numb  +  1  )  )  then 
file_numb  file_numb  -  (  maxjproc__numb  +  l  ) ; 

if  test_char  -  * . *  then  begin 
count  0; 
repeat 

read(input_file, test_char) ; 
if  eof (input_file)  then 
eof_flag  true 

else 

eof_flag  :»  false; 
if  ( (test_char  in  [’O’.. ’9’])  and 

((count+1)  <-  max_digits))  then  begin 
storage  [count+11  test_char; 

count  count  +  1; 

end; 

until  (  (test_char  in  chr (space) } )  ); 

if  count  -  0  then 

processor . repea t_f actor (comm_count]  1 


else 
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processor . repeat_f act or l comm_count ]  : - 
convert_to_integer (  count,  storage  ) 

end 

else 

processor. repea t_factor [comm_count]  1; 

end 

end; 

end; 

if  stop_proc  then  error_log[2]  : ■  1 
end;  {  FUNCTION  read_numb  } 


PROCEDURE  comment; 

var 

test_char  :  char; 

begin 

repeat 

test_char  read_char; 
until  (  (test_char  -  »]*)  or  stop_proc  ); 
if  stopjproc  then  error_logf3]  !•  1; 

end;  {  PROCEDURE  comment  } 


PROCEDURE  check_loop; 

var 

test_char  :  char; 

begin 

test_char  read_char; 
if  test_char  -  ’O'  then  begin 
test_char  read_char; 
if  test_char  -  ’O’  then  begin 
test_char  read_char; 
if  test_char  <>  fP*  then 
stop_proc  true; 

end 

else 

stopjproc  true; 

end 

else 


stop_proc  :«•  true; 


if  stop_proc  then  error_log[5]  s-  1; 
end;  {  PROCEDURE  check_loop  } 

PROCEDURE  check_cycle; 

var 

test_char  :  char; 

begin 

test_char  read_char; 
if  test_char  -  ,Y'  then  begin 
test^char  read^char; 
if  test_char  -  *C’  then  begin 
test_char  read_char; 
if  test_char  -  *L*  then  begin 
test_char  read_char; 
if  test_char  <>  *E’  then 
stop_proc  true; 

end 

else 

stop_proe  :■»  true; 

end 

else 

stopjproc  true; 

end 

else 

stopjproc  true; 

if  not  stop_proc  then  begin 
repeat 

test_char  read_char; 

if  test_char  -  ' [ *  then  comment; 
untilC  (test_char  -  *P')  or  stop_proc  ) 
if  stop_proc  then  error_log [30 ]  ;•  1; 

end 

else 

error_log[6]  1; 

end;  {  PROCEDURE  checfc_cycle  f 


PROCEDURE  set_clear_data; 

var 

i,  j,  k  :  integer; 


begin 
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for  i  0  to  max_x_bus  do 

for  j  min_y_bus  to  max_proc_numb  do 
clear_matrix[i] [ j]  11; 

clear_tran. count  0; 

for  j  1  to  raax_com«  do  begin 

clear_proc . repeat_f actor [ j ]  :-0; 
clear__tran.  sender  tj]  *"  0; 
clear_tran . receiver [ j 1  0; 

end; 

for  i  0  to  max_proc_numb  do  begin 
for  j  s-  1  to  raax^comra  do  begin 

clear_proc.  receiver  [j  Hi]  0; 
clear_proc. sender tjl li)  J*  0; 

end; 

end; 

for  i  1  to  max_errors  do 
error__log  [i]  0; 

end;  {  PROCEDURE  set_clear_data  } 


PROCEDURE  get_loop_nuraber {  var  last_char  :  char  ); 

var 

test_char  :  char; 

begin 

check_loop; 

if  not  atopjproc  then  begin 

jump__n  umber  step_number  *  1; 
jump_cycle  ;«  cycle_number  +  1; 
jump_flag  true; 

repeat 

test_char  read_char; 
if  test_char  -  then  comment; 
until  {  (test_char  -  *C’)  or  stop_proc  ); 
last^char  test_char; 

if  stopjproc  then  error_log[8|  1? 

end; 

end;  {  PROCEDURE  get_loop_number  ) 


PROCEDURE  get_receivers (  var  found  :  boolean  ) ; 

var 

test^char  ;  char; 
stop_loop  :  boolean; 
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index  :  integer; 

begin 

found  s-  false; 
stop_loop  false; 
repeat 

read_nurab(  fR*,  index  ); 
if  stopjproc  then  begin 
stop_proc  true; 
error_log[9]  1; 

end 

else  begin 

found  : -  true ; 

if  processor .receiver [comm_count][ index]  -  1  then  begin 
stop_proe  true; 

errorJLogtlO]  :*•  1; 

end 

else 

processor .receiver [comra_count] [index]  :«  1; 

end; 

if  not  stopjproc  then 
repeat 

testjshar  read_char; 

if  test_char  -  * [ f  then  comment; 
if  stopjproc  then  error_log[ll]  1; 
until {  (test_char  in  [ ’P * , , ’C* ] )  or  stopjproc  ); 

if  not  stopjproc  then 
case  test_char  of 
*-*  ;  begin 

stop_loop  true; 

if  not  found  then  stop__proc  true; 
end; 

fCf  :  begin 

stopjjroc  true; 

if  stopjproc  then  error_log[13]  1; 

end; 

end; 

until (  stop  __loop  or  stopjjroc  ) ; 
end;  {  PROCEDURE  get  jrecei  vers  } 


PROCEDURE  get_sender (  var  found  :  boolean;  var  input _char  ;  char  ) ; 

var 

test_char  :  char; 
index  s  integer; 


begin 


found  :•  false; 
repeat 

test_char  read_char; 
if  test_char  -  ' [♦  then  comment; 
if  stop_proc  then  error_log[14]  1; 
until {  <test_char  in  [ *P* . ’ ;  \ ’C* ] >  or  stop__proc  ); 

if  not  stopjproe  then  begin 
case  test_char  of 
’Pf  :  begin 

readjiurab(  ’S’,  index  ); 
if  stop_proc  then  begin 
stopjproe  ;»  true; 
error_log(15] s-  1; 

end 

else  begin 

if  processor . sender [comra_count] [index]  ■  1  then  begin 
stopjproe  true; 
error_log[16]  1; 

end 

else 

proces sor. sender [comm__count]  [index]  1; 

found  true; 

end; 

end; 

f : *  :  begin 

stop_proc  true; 
error_log[X7]  1; 

end; 

’C’  ;  begin 

stopjproe  true; 
error_log[18]  1; 

end; 

end; 

end; 

if  not  stop_proc  then  begin 
if  not  eof_flag  then 
repeat 

test_char  ;«  read_char: 
if  test_char  -  'I'  then  comment; 
until (  (test_char  in  (»Pf,»C\,L']>  or  stopjproe  ); 
if  eof_flag  then  begin 
stopjproe  false; 
test_char  ’Q’; 

end; 

input_char  test_char; 


end; 
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end;  {  PROCEDURE  get_sender  } 


PROCEDURE  initialize_comm_info; 
begin 

processor  clear__proc; 
xtox  clear_tran; 

xtoy  clear_tran; 

ytox  clear_tran; 

ytoy  clear_tran; 

end;  {  PROCEDURE  initialize_comra_info  } 


PROCEDURE  check  sender  receivers; 


var 

i,  j  :  integer; 


begin 

for  i  :■  0  to  max_proc_numb  do 
xbar_bus[i]  ’  * ; 
for  j  :»  1  to  comm^count  do 

for  i  0  to  max_proc_numb  do  begin 
if  processor. sender (j Hi]  -  1  then 

if  (xbar__bus(i]  -  *R#)  or  (xbar_bus[i]  -  ’S')  then 
stop_proc  : -  true 

else 

xbar_bus[i]  *S'; 

if  processor. receiver! j] li]  -  1  then 

if  (xbar_bus(i]  -  ’R')  or  <xbar_bus[i]  -  *s*)  then 
stop_proc  j-  true 

else 

xbar__bus[i]  "Rf; 

end; 

if  stop_proc  then  error_log[25]  1; 
end;  {  PROCEDURE  check_sender_receivers  } 


PROCEDURE  write_seq_to_output_file (  last_one  :  boolean  ); 


var 


i.  1. 

out_count  :  integer; 
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first_coinm  :  boolean; 

begin 

first_cojnm  true; 
out_oount  0; 

writeln (setup, ’  Cycle  * , cycle_number) ; 
for  j  :■  1  to  comm_count  do  begin 
for  i  0  to  max_proc_numb  do 

if  processor .receiver [j] [ij  -  1  then 
if  first_comra  then  begin 

write ( setup, '  p ' , i ) ; 

first_corem  false; 

end 

else  begin 

write (setup, ’ ,  p',i); 
out_count  : -  out_count  +  1; 
if  out_count  >-  7  then  begin 
writeln (setup, * , * ) ; 
first_corcra  true; 
out_count  0; 

end; 

end; 

write (setup, f  '); 

for  i  0  to  max_proc_nunib  do 

if  processor. sender [j] (il  -  1  then 

write (setup, 'p* , i, * . * , processor . repeat_f actor [ j ] , * ; f 
writeln ( setup) ; 
first__conun  true; 

end; 

if  last_one  then  begin 
writeln (setup) ; 
if  jurep_flag  then 

writeln (setup, »  Loop  to  Cycle  -  ’ , jump_cycle) 

else 

writeln (setup, *  No  loop * ) ; 

end; 

end;  {  PROCEDURE  write_seq_to_output_file  ) 


PROCEDURE  build_data_word (  now  ;  integer;  input_word  :  proc_array; 

var  output_word  :  word_array  ) ; 


var 


i,  j  ;  integer; 


begin 
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for  i  0  to  max_proc_numb  do 
output_word [i]  0; 

for  j  !»  1  to  coram__count  do 

if  now  <-  processor. repeat__f  actor  [  j  ]  then 
for  i  i*  0  to  max_proc_numb  do 
if  input_vord [ j ] [i)  -  1  then 
output_word[i]  1; 

end;  {  PROCEDURE  build_data_word  ) 


FUNCTION  raake_hex_nirnb<  index  :  integer;  input^word  :  word__array  )  :  integer; 

var 

j,  input_value  :  integer; 

begin 


input_value  0; 

for  j  1  to  (bits_in_word  div  2)  do 

input_value  input_value  +  input_word[ j+ index]  *  power ( ( j-1) , 2) ; 
make_hex_nuinb  input_value; 

end;  {  FUNCTION  raa ke_hex_numb  ) 


PROCEDURE  write_data_word (  which_one  :  char;  data_word  ;  word_array  ); 

var 

j,  output_value  :  integer; 

begin 

j  -1; 
repeat 

output_value  make_hex_nuinb <  j,  data_word  ); 
write_byte (  which_one,  output_value  ); 

j  j  +  8; 

until <  j  >  23  >; 

end;  {  PROCEDURE  write_data_word  } 


PROCEDURE  itjake_four_hex_nuntb(  which_one  :  char;  address  :  integer  ); 


var 

upper,  lower  ;  integer; 


begin 
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upper  :•  address  div  256; 
lover  j-  address  mod  256; 
write_byte<  which_one,  lower  ); 
write_byte(  vhich_one,  upper  ); 

end;  {  PROCEDURE  raake_four_hex_numb  } 


PROCEDURE  make__check_sura<  which_one  :  char  ); 

begin 

checksum  s—  -  checksum : 
write_byte<  which_one,  checksum  ); 

end;  {  PROCEDURE  make_check_sura  } 


PROCEDURE  write_in_hex  (  address_to_output  :  integer  ) ; 

var 

output_nurcber , 

left_over, 

hex— count  ;  word; 

begin 

left_over  address_to_output ; 

for  hex_count  3  downto  0  do  begin 

output__number  left-over  div  power  (hex_count,  16); 
left_over  left_over  -  output_number  *  power (hex_count,  16); 
if  output_nuraber  <  IQ  then 

write (addr_setup, output_number ; 1) 
else  if  output_nuraber  -  10  then 
write <addr_setup, *A') 
else  if  output_number  -  11  then 
write (addr_setup, ’B*) 
else  if  outputjiumber  -  12  then 
write (addr^setup,  *c*) 
else  if  output_number  -  13  then 
write {addr_setup, ’D*) 
else  if  output_number  «  14  then 
write ( addr^setup , *  E ' ) 
else  if  output_number  -  15  then 
write (addr_setup, *F* ) ; 

end; 

end;  {  PROCEDURE  write_in_hex  } 


PROCEDURE  generate_seq_code <  last_one  :  boolean  ) ; 

var 

i*  j, 

start  s  integer; 

data_word  :  word_array; 

begin 

start  processor .repeat_f actor [1] ; 

for  i  :•  1  to  corcm_count  do 

if  processor.repeat_factor [ i ]  >  start  then 
start  processor .repeat_f actor [ij ; 

if  gen_addr  then  write (addr_set up, *  ' , cycle_number: 4) ; 

for  i  1  to  start  do  begin 

step_number  step_nuinber  +  1; 
if  step^nuraber  <-  max_step  then  begin 

nura_abs_seq_sets_output  num_abs_seq_sets_output+l 

build_data_word (  i,  processor .receiver,  data_word  ); 
write_data_word (  ’  S  * ,  data_word  ) ; 
build_data_word (  i,  processor. sender,  data_word  ); 
write_data_word  (  '  S  * ,  data_word  )  ; 

if  i  <>  start  then  begin 

raake_four_hex_numb {  'S',  cycle_number  -  1  ); 
if  gen_addr  then  begin 
if  i  -  1  then  begin 

write {addr_setup, '  '); 

write_in__hex  (cy  cl  e_n  umber  -  l); 

end 

else  begin 

write (addr_setup, *  '); 

write_in_hex ( cy cl e_n umber  -  1); 

end 

end 

end 

else  if  {  i  -  start)  and  last_one  then  begin 
if  not  jump_flag  then 

jump_cycle  cycle__number  +  l; 
make_four__hex_numb(  'S’,  jump_cycle  -  1  ); 
if  gen_addr  then  begin 
if  i  -  1  then  begin 

write (addr_setup, *  ’ ) ; 

write_in_hex (jump_cycle  -  1); 


end 

else  begin 
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write  (addr_set  up, '  *); 

write_in_hex ( jurap_cycle  -1); 

end 

end 

end 

else  begin 

make_four_hex_numb (  ’S’,  cycle_number  );; 
if  gen_addr  then  begin 
if  i  -  1  then  begin 

write  <addr_setup, *  ' ) i 

writeJLn_hex<cycle_number) ; 

end 

else  begin 

write  (addr_setup,  •  * )  ** 

write_in_hex (eycle_number) ; 

end 

end 

end; 

if  {  i  -  start)  and  last_one  then  begin 
if  not  jump_flag  then 

jurnp_n  umber  step_number  +1; 

raake_f  our_hex_nuinb (  ’S’,  jump_number  -  1  ); 
if  gen_addr  then  begin 

write (addr_setup, '  ' ) ; 

write_in_hex ( jurap_number  -  1); 
writeln(addr_setup) ; 

end 

end 

else  begin 

ma)ce_four_hex_numb(  'S’,  step_number  ); 
if  gen_addr  then  begin 

write (addr_setup, '  ' ) : 

writejLn_hex  (step_number)  ; 
writeln(addr_setup) ; 

end; 

end; 

write_byte (’S', 00H) ;  {  Four  unused  memory  locations  } 

write_byte (’S', 00H) ; 
write_byte ( ' S ' , 00H) ; 
write_byte ( ' S  * ,  00H) ; 

end; 

end; 

if  step_nuraber  >  max_step  then  begin 
stop_proc  true; 
error_log [281  :■  1; 

end 

else  begin 

wr it eln ( *  Cycle  * , cycle_number ) ; 
if  gen_setup  then 

write_seq_to_output_file  <  last_one  ) ; 
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end; 

end?  {  PROCEDURE  generate_seq_code  } 


PROCEDURE  wr i t  e_xba r_to_output_f lie; 

var 

i,  j  s  integer? 


begin 

writeln (setup) ; 

vriteln ( setup, *  Crossbar  Setup'); 
writeln (setup) ; 
write ( setup, *  X?); 

for  i  :■*  0  to  max_x_bus  do 
if  i  <  10  then 

write (setup, *  '  ,i) 

else 

write ( setup, '  *,i); 

writeln (setup) ; 
write (setup, *  Y  ' ) ; 
for  i  :■  0  to  max_x_bus  do 
if  xbar_bus[i]  -  1  *  then 
write (setup, •  ’) 

else  if  xbar_bus(i]  -  *R*  then 
write ( setup, *  REC • ) 
else  if  xbar_busti}  -  'S'  then 
write ( setup, ’  SND ’ ) 
else  if  xbar_bus[i]  -  'H*  then 
write ( setup, *  HLF ' ) ; 
writeln ( setup) ; 
writeln (setup) ; 

for  i  rain_y_bus  to  max_proc_nurab  do  begin 
if  (i  -  min_y_bus)  <  10  then 

write (setup, '  * r(i  -  rain_y_bus)) 

else 

write(setup, (i  -  min_y_bus) ) ; 
write ( setup, *  *); 
if  xbar_bus[i]  -  ’  •  then 
write (setup, '  ') 

else  if  xbar_bus[i)  -  'R*  then 
write (setup, 'REC  ') 
else  if  xbar_bus[i]  -  'S'  then 
write ( setup, ' SND  ' ) 
else  if  xbar_bus(i]  -  'H'  then 
write (setup, 'HLF  '); 
for  j  i-  0  to  max_x_bus  do 

if  xbar_matrix( j] [i]  -  11  then 
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write < setup, •-  *> 

else  if  xbar_matrix( jj tij  -  00  then 
write < setup, *YX  * ) 
else  if  xbarjmatrix ( j  ] £ i ]  -  01  then 
write  (setup,  * XY  * )  .* 
writeln (setup) ; 

end; 

writeln ( setup) ; 

end;  {  PROCEDURE  write_xbar_to_output_file  ) 


PROCEDURE  raake_x_y_y_x  (  bus_to_bus  :  transfer  >; 

var 

i,  sender_index  :  integer; 

begin 

i  0; 
repeat 

i  s-  i  +  1; 

sender_index  bus_to_bus.sender[i] ; 
if  sender_index  in  [0..1S]  then 
if  xbarjnatrix [ sender_index) 

[bus_to_bus.reeeiver (i] ]  <>  11  then 
stopjproc  true 

else 

xbar_matrix  I  sender__index] 

[bus_to_bus. receiver [i] ]  01 

else  if  sender_index  in  (16.. 31]  then 

if  xbar_raatrix [bus_to_bus . receiver ( i] ] 
lsender_index]  <>  11  then 
stop_proc  true 

else 

xbarjnatrix (bu3_to_bus . receiver (i] ] 
(sender_index]  00; 

until  (  (i  -  bus_to_bus. count)  or  stop_proc  ); 
if  stopjproc  then  error_log(26]  1; 

end;  {  PROCEDURE  make_x_y_y_x  ) 


PROCEDURE  make_x_x_y_y (  bus_to_bus  :  transfer  ); 

var 

i,  j,  sender_index, 
receiver_index, 
empty_bus  :  integer; 
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begin 

i  0; 
repeat 

i  i  +  1; 

sender_index  bus_to_bus . sender [i] ; 
receiver_index  : -  bus_to_bus . receiver [ i ] ; 
if  sender_index  in  [0..15]  then  begin 
erapty_bus  -1; 
j  s-  max_x_bus; 
repeat 

j  s-  j  +  1; 

if  xbar_matrix[sender_index] [j]  -  01  then 
empty Jaus  s-  j; 

until (  (empty_bus  <>  -1)  or  (j  -  raax_proc__numb)  ); 
if  empty__bus  -  -1  then  begin 
j  max_x_bus; 
repeat 

j  j  +  1» 

if  xbar_bus[j]  -  *  *  then 
empty  __bus  j; 

until  (  (empty_bU3  <>  -1)  or  (j  -  max_proc_numb)  ); 

end; 

if  erapty_bus  -  -1  then  begin 
stop_proc  true; 
error_log[27]  1; 

end 

else  begin 

if  xbar_bus[empty__bus]  -  '  r  then 
xbar_bus [empty_bus]  'H'; 
if  xbar_matrix(sender_index} [empty_bus]  <>  01  then 
xbar_raatrix[sender_index] [ empty _bua] - 01; 
if  xbar_raatrix[receiver_index] [ empty  Jous]  <>  11  then 
stop_proc  true 

else 

xbar_matrix [receiver_index] [empty_bu3]  00; 
if  stop_proc  then  error_log[27]  1; 

end; 

end 

else  if  sender_index  in  [16. -31]  then  begin 
empty_bus  -1; 
j  0; 
repeat 

if  xbar_matrix [ j ] [sender_index]  -  00  then 
empty _bus  : -  j ; 

j  «-  j  +  i; 

until {  (empty_bus  <>  -1)  or  (j  >  max_x_bus)  ); 
if  empty_bus  *  -1  then  begin 


j  0; 

repeat 
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if  xbar_bus(j]  -  *  '  then 

ercpty_bu3  j ; 

j  j  +  i* 

until  (  (empty_bus  <>  -1)  or  (j  >  max_x_bus)  ); 
end; 

if  empty_bus  -  -1  then  begin 
3top__proc  true; 
error_log(27]  ;•  1; 

end 

else  begin 

if  xbar_bus  tempt  yjsus]  -  *  ’  then 
xbar_bus [empty_busj  'H*; 
if  xbar^matrix  J  empty_bus  3 [sender_index]  <>00  then 
xbar_matrix [empty  Jbus] [sender_index]  00; 

if  xbar_matrix[empty_bus] [receiver_index]  <>  11  then 
stopjproc  true 

else 

xbar^raatrix  tempt  yjaus] [receiver_index]  01; 
if  stop__proc  then  error_log[27]  1; 

end; 

end; 

until  t  (i  -  bus_to_bus . count )  or  stop_proc  ) ; 
end;  {  PROCEDURE  make_x_xj/_y  } 


PROCEDURE  make_xbar_raatrix; 

var 

i,  j  :  integer; 

begin 

xbar_matrix  clear_raatrix; 

if  xtoy. count  <>  0  then  raake_x_y_y_x (  xtoy  ); 
if  not  stopjproc  then  begin 

if  ytox. count  <>  0  then  raake_x_y_y_x (  ytox  ); 
if  not  stop_proc  then  begin 

if  xt ox. count  <>  0  then  make_x_x_y_y (  xtox  ); 
if  not  stop_proc  then 

if  ytoy. count  <>  0  then  make_x_x_y_y {  ytoy  ); 

end; 

end; 

end;  {  PROCEDURE  make_xbar_matrix  ) 


PROCEDURE  rotate_matrix  (  rotate__count ,  x_index,  y_index  ;  integer  ); 
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var 

nev_x, 
nev_y, 
recount, 
x_count , 
y_count , 

terop_data  :  integer; 
temp_raatrix  :  raat_array; 

begin 

for  recount  1  to  rotate_count  do  begin 
temp_matrix  xbar_matrix; 

for  x— count  x_index  to  (x^index  +  fourth_xbar)  do 

for  y^count  y_index  to  {y_index  +  fourth_xbar) 
nev_y  {x_count  -  x_index)  +  y_index; 
new_x  (fourth_xbar  +  x_index)  -  (y_count  - 
temp_data  tempjmatrix{x_count]  [y_^count] ; 
if  ten»p_data  -  00  then 
temp_data  01 

else  if  temp_data  -  01  then 
terap_data  :•  00 

else 

temp_data  11; 

xbar_raatrixfnew_xj lnew_y]  terap_data; 

end; 

end; 

end;  {  PROCEDURE  rotatejnatrix  } 


PROCEDURE  transform_xbar_matrix; 

var 

x_index, 

y_index  :  integer; 

begin 

x_index  0; 

y_index  min_y_bus  +  fourth_xbar  +  1; 

rotate_matr ix  (  1,  x_index,  y_index  ); 

x_index  fourth_xbar  +  1; 

y_index  min_y_bus  +  fourth_xbar  +  1; 

rotate_matrix (  2,  x_index,  y_index  ); 

x_index  fourth_xbar  +1; 

y_index  j-  min_y_bus; 


do  begin 

y_index) ; 
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rotate_raatrix {  3,  x_index,  y_index  ); 
end;  {  PROCEDURE  transform_xbar_raatrix  > 


PROCEDURE  generate_xbar_absolute_code <  xjLndex,  y_index  :  integer  )? 

var 

index, 
x__count , 

y_count  :  integer; 
data_word  :  word_array; 

begin 

index  :«•  0; 

for  x^count  x_index  to  (x_index  ♦  fourth__xbar)  do 

for  y_count  y_index  to  (y_index  fourth_xbar)  do  begin 
if  xbar_matrix[x_count] [y_count]  -  00  then  begin 
data_word[ index]  0; 

data_yordfindex+l]  0; 

index  index  +  2; 

end 

else  if  xbarjmatrix{x_eount] [y_count]  -  01  then  begin 
data_word[ index]  1; 

data_word(index+l]  0; 

index  :«•  index  +  2; 

end 

else  begin 

data_word( index]  1; 

data_word[index+l]  1; 

index  s-  index  +2; 

end; 

if  index  >  30  then  begin 
index  :«  0; 

write_data_word (  ’ X * ,  data_word  ) ; 

end; 

end; 

end;  {  PROCEDURE  generate_xbar__absolute_code  ] 


PROCEDURE  write_xbar_data; 

var 

x_index, 

y_index  :  integer; 


begin 
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x_index  0; 

y_index  min_y__bus; 

generate_xbar_absolute_code (  x_index,  y_index  ) ; 
x_index  0; 

y_index  min_y_bua  +  fourth_xbar  +  1; 

generate__xbar_absolute_code  (  x_index,  y_index  )? 

x_index  fourth_xbar  +1; 

y_index  rain_y_bus  +  fourth^xbar  +  1; 

generate_xbar_absolute_code (  x_index,  y_index  ); 

x_index  fourth^xbar  +1; 

y_index  :•  m±n_y_bus ; 

generate_xbar_absolute_code <  x_indexr  y_index  ); 
end;  {  PROCEDURE  write_xbar_data  } 


PROCEDURE  complete_xbar_code ; 

var 

byte_count  :  integer; 

begin 

transform_xbar_raatrix; 

num_abs_xbar_sets_output  num_abs_xbar_sets_output+l 
write_xbar_data ; 

end;  {  PROCEDURE  complete_xbar_code  } 


PROCEDURE  gene rat e_xbar_code; 


var 


sender_index, 
receiver_index  :  integer; 
stop_loop  :  boolean; 

begin 


xtox .  count 

xtoy .  count 

ytox .  count 

ytoy .  count 
for  j  1 


0; 

0; 

0; 

0; 

to  comm_count  do  begin 


sender_index  *-  0: 

*top_loop  :*•  false; 
repeat 

if  processor. sender [j] [sender_index]  -  1  then 
stop_loop  true 

else 

sender_index  sender_index  +  1; 
until (  stop_loop  ) ; 

for  i  0  to  max_proc_nurab  do  begin 

if  (processor. receiver  I jl [i]  -  1)  and 
(i  <>  sender_index)  then  begin 
receiver_index  :•  i; 
if  sender_index  in  [0..15]  then 

if  receiver_index  in  [Q..15]  then  begin 
xtox. count  xtox. count  +  1; 
xtox. sender [xtox. count]  sender_index; 

xtox.  receiver [xtox. count]  i; 

end 

else  begin 

xtoy.  count  xtoy. count  +  1; 

xtoy. sender [xtoy. count]  sender_index; 

xtoy. receiver [xtoy. count]  i; 

end 

else  if  sender_JLndex  in  (16.. 31]  then 

if  receive  r__index  in  [0..15]  then  begin 
ytox. count  ytox. count  +1; 
ytox. sender [ytox. count]  3ender_index; 

ytox.  receiver (ytox. count]  i; 

end 

else  begin 

ytoy.  count  ytoy. count  +1; 

ytoy. sender (ytoy. count]  sender_index; 

ytoy. receiver [ytoy .count]  i; 

end; 

end; 

end; 

end; 

ma  fce_xba r_ma  t r ix ; 
if  not  3topjproc  then  begin 
if  gen_setup  then 

write_xbar_to_output_f ile ; 
complete_xbar_code : 

end; 

end;  {  PROCEDURE  generate_xbar_code  ) 


PROCEDURE  proce»s_cycle{  var  last_char  :  char  ): 

var 

receiver  s__found, 
sender_found  i  boolean; 

begin 

check_cycle; 

if  not  stop_proc  then  begin 

cycle_n umber  j-  cycle_number  +1; 
initialize_coram_info; 
corcra_count  0; 
repeat 

comm_eount  comm_count  +  1; 
if  corora_count  >  max_comm  then  begin 
3top_proc  true; 
error_log[21]  1; 

end; 

if  not  stop_proc  then  begin 

get_receivers <  receivers_found  ); 
if  receivers_found  and  not  stop_proc  then  begin 
get_sender(  sender_found,  last_char  ); 
if  not  sender^found  and  not  stop_proc  then  begin 
*top_proc  true; 

error_log[23J  1; 

end 

end 

else  begin 

stop_proc  true; 
error_logt22]  1; 

end; 

end; 

until (  <last_char  in  [ ’C* , ’Q' , *L' ] )  or  stop_proc  ); 

if  not  stop_proc  then  begin 
check_sender_receivers; 
if  not  stop_proc  then  begin 
if  last_char  -  rQ'  then 

generate_seq_code (  true  ) 

else 

generate_seq_code {  false); 
if  not  stop_proc  then  generate_xbar_ code; 

end; 

end; 

end; 


end;  {  PROCEDURE  process_cycle  } 
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PROCEDURE  proces*_loop<  var  last_char  :  char  ); 
begin 

get_loop_number (  last_char  ); 
end;  {  PROCEDURE  process__loop  ) 


PROCEDURE  process_file; 

var 

test_char, 
last_char  :  char; 

begin 

jurap_flag  false; 

cycle_nuraber  s-  0; 
step_nuraber  0; 

jurap_munber  0; 

test_ehar  read_char; 

repeat 

if  test_char  -  *C*  then  process_cycle (  last_char  ) 
else  if  test_char  -  *Q'  then  stop_proc  true 
else  if  test_char  -  *L*  then  process_loop<  last_char  ) 
else  if  test_char  -  '  t T  then  begin 

comment ; 

lastchar  read_char; 

end 

else  last_char  read_char; 

test_char  last_char; 
until  (  stopjproc  ); 

if  cycle_number  -  0  then  error_log[24]  1; 
end;  {  PROCEDURE  process_file  ) 


PROCEDURE  error_checX; 

var 

i  ;  integer; 

no_errors  :  boolean; 
error  file  ;  text; 


begin 


274 


no_errors  true; 

for  i  i-  1  to  max_errors  do 

if  error_log[i]  -  1  then  no_errors  false; 
if  not  no_errors  then  begin 
writeln; 

writeln ('  Error  detected  in  cycle  -  * , cycle_number, 

*  , check  error.dat  file.*); 

writeln; 

rewrite ( err or_f ile , *  error . dat * ) ; 
writeln (error_file) ; 
writeln (error_f ile) ; 

writeln  (error^f  ile,  *  For  cycle  -  ' ,  cycle__number) ; 
writeln  (error_f ile ) ; 
for  i  !•  1  to  max_errors  do 
%  if  error_lag[i]  <>  0  then 
case  i  of 

1  ;  writeln {error_file, *  encountered  eof  while  trying  to  read  character' ); 

2  i  writeln ( err or_f ile, *  encountered  eof  while  trying  to  read  number'); 

3  ;  writeln (error__file,  *  never  found  1  for  comment  end'); 

4  j  writeln {error_file, *  error  checking  BEGIN’); 

5  :  writeln <error_file, *  error  checking  LOOP'); 

6  i  writeln (error_file, *  error  checking  CYCLE'); 

7  :  writeln (error_file, '  error  checking  END'); 

8  ;  writeln (error_f ile, ’  never  found  CYCLE  after  LOOP'); 

9  ;  writeln ( err or_f ile, *  receiver  -  no  processor  number  found*); 

10  ;  writeln (error_f ile, '  receiver  -  same  receiver  used  again'); 

11  :  writeln (error^file, *  receiver  -  never  found  P,  ;  or  C'); 

12  :  writeln <error_f ile, '  receiver  -  not  found'); 

13  :  writeln (error_ file, '  receiver  -  found  C  before  any  processors'); 

14  :  writeln (error_f ile, *  sender  -  never  found  P,  ;  or  C); 

15  s  writeln (error_file, '  sender  -  no  processor  number  found'); 

16  ;  writeln {error_f ile, '  sender  -  same  sender  used  again'); 

17  :  writeln (error_file, ’  sender  -  found  ;  before  any  processor'); 

18  :  writeln (errorJT lie, '  sender  -  found  C  before  any  processor'); 

19  ;  writeln (error_file, *  sender  -  never  found  P,  C,  L  or  E*); 

20  :  writeln (error__f ile,  '  sender  and  receiver  with  same  processor  number'); 

21  ;  writeln (error_file, '  over  sixteen  communications  in  one  cycle’); 

22  t  writeln (error_f ile, '  no  receivers  found*); 

23  :  writeln (error_file, '  no  senders  found*); 

24  :  writeln (error_f ile, '  never  found  C  or  L  to  start  processing'); 

25  :  writeln (error^f ile, *  processor  used  more  than  once  in  a  cycle'); 

26  :  writeln (error_f ile, '  x  to  y  or  y  to  x  bus  conflict  on  xbar'); 

27  :  writeln (error^f ile, '  x  to  x  or  y  to  y  no  empty  buses  found*); 

28  :  writeln {error_f ile, '  exceded  maximum  step  count  for  sequencer’); 

29  :  writeln (error_file, '  exceded  maximum  cycle  count  for  sequencer'); 

30  :  writeln {error_file, '  after  cycle  never  found  P'); 

end; 

end; 


end;  {  PROCEDURE  error_check  ) 
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{  Main  Program  } 

begin 

open_files? 

initialize_output_files? 
»et_clear_data; 
process^ file; 
finish_output_filea  ,* 
error  check; 


end. 
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E.  Spinning  Missile  source  code 


Copyright  1990 

Georgia  Tech  Research  Corporation 
Centennial  Research  Building 
Atlanta,  GA  30332 


File:  BLOCKOO.PAS 


Module  Problem_Specifications; 

Public  ProblemjSpecifications; 

Procedure  InitializeJTable; 

Procedure  Evaluate_Table (  time  :  Real  ) ; 

Public  Solve_Table; 


Var  time,  integration_step  :  Real; 
$ Include  {* :PFP:include/target.pas' ) 


Private  Problera_Specifications; 


const 

num_points  -  16; 


low_last, 

high_last 


:  integer; 


rraf_table 

index_table 

diff_table 


array  [1.  .numjpoints]  of  real; 
array  [1 . .num_points]  of  real; 
array  II. .num_points]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

message_type,  message_size  :  integer; 

begin 

input_message {  message_type,  integration_step,  message_size  ); 
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low— last  1; 

high_last  nura_points; 


index_table [ 1 ] 

-  0.0; 

index_table [2 J 

0.07; 

index_table[3] 

-  0.25; 

index_table [4] 

0.35; 

index_table [ 5 ] 

-  0.5; 

index_table[6] 

1.0; 

index_table [ 7 ] 

-  1.47; 

index_table[8] 

1.5; 

index_table(9] 

-  2.0; 

index_table [10 ) 

2.5; 

index_table [11] 

-  3.0; 

index_table  [12] 

3.5; 

index_table [ 13 ] 

-  4.0; 

index_table[14] 

4.393; 

index_table [IS] 

-  4.394; 

index_table[ 16] 

9.9995; 

mf— table  [1] 

1 . 1184E-2; 

rmf_table [2] 

1 . 1236E-2; 

rraf_table[3] 

1.1371E-2; 

rmf_table{4] 

s-  1 . 14458E-2; 

rraf_table [5] 

1.1558E-2; 

raf_table [6] 

1.202E-2; 

rmf_table [ 7 ] 

1.2494E-2; 

rnf__table  [  8  ] 

1.2524E-2; 

rmf_table[9] 

1.3068E-2; 

rmf_table [10] 

1.366E-2; 

rrof_table[ll] 

1.4302E-2; 

rmf_table[l2] 

1 . 5008E-2; 

rraff_table[13] 

1.579E-2; 

rmf_table [14] 

1.6464E-2; 

rmf_table[15] 

1.6466E-2; 

rraf_table  [16] 

1 . 6466E-2; 

for  count  2  to  nura_points  do 

diff  table [count]  (rraf_table [count]  -  rmf_table [count-1] )  / 

( index_table [count ]  -  index_t able [ count-1 ] ) ; 

end;  {  Procedure  Initialize_table  ) 


Procedure  pivot (  var  ihigh,  ilow  :  integer;  search_value  :  real  ); 

var 

ipiv  :  integer; 

begin 

while  { (ihigh  -  ilow)  >  1)  do  begin 
ipiv  (ihigh  +  ilow)  div  2; 

if  search_value  -  index_table [ipiv]  then  begin 
ilow  ipiv; 
ihigh  ilow  +1; 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  ipiv 
else 

ilow  ipiv; 

end; 


end;  {  Procedure  pivot  } 
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Function  search_table {  search_value  :  real  )  :  integer; 

var 

ihigh, 

ilow  i  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table[ilow] )  and 

(search_value  <  index^table [ ihigh] )  then  begin 
pivot {  ihigh,  ilow,  search_value  ) ; 


end 

else  if  search_value  -  index_tabletilow]  then  begin 
ihigh  ilow  +1; 

end 

else  if  search_value  -  index_table [ihigh]  then  begin 
ilow  ihigh; 

ihigh  ilow  +1; 

end 

else  if  search__value  <  index_table [  1  ]  then  begin 
ihigh  2; 

ilow  1; 

end 

else  if  search_value  >  index_table[num_points]  then  begin 
ihigh  nure_points; 

ilow  i-  ihigh  -  1; 

end 

else  if  search_value  >  index_table [ihigh]  then  begin 
ihigh  :»  num_points; 
pivot (  ihigh,  ilow,  search_value  ) ; 

end 

else  if  search_value  <  index_table [ilow]  then  begin 
ilow  1; 

pivot (  ihigh,  ilow,  search_value  ); 

end; 

low_last  ilow; 

high_last  ihigh; 

search_table  ihigh; 
end;  [  Function  search_table  } 


Procedure  Evaluate_table (  time  :  real  ); 
{ 
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Table  RMF  -  Block  0 

var 

sub_index, 

index  s  integer; 

rraf  :  real; 

begin 

index  search_table<  time  ); 
sub_index  index  -  1; 
rmf  rraf_table[9ub_index]  + 
(diff_table[ index]  * 

(time  -  index_table [ sub_index ] ) ) ; 
Send_Real_32bit {  rmf  ) ; 

end;.  {  Procedure  Evaluate_table  } 
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File:  BLOCKOl.PAS 

Module  Problem_Specifications; 

Public  Problera_Specifications; 

Procedure  InitializeJTable; 

Procedure  EvaluateJTable (  time  :  Real  )? 

Public  Solve_Table; 

var  time,  integration_step  :  Real; 

$Include  (* :PFP: include/target. pas’) 

Private  Problem_Specifications; 

const 

numjpoints  -  16; 

var 

low^last, 

high_last  :  integer;  ■> 

tf__table  :  array  [1. ,num_points]  of  real; 

indextable  :  array  [1 . .numjpoints]  of  real; 
diff_table  :  array  [1. .nura_points)  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

message_type,  message_size  :  integer; 

begin 

input_message (  message_type,  integration_step,  message_size  ); 

low_la3t  1; 
high_last  numjpoints; 


index__table  ( 1  ] 

0.0; 

indeXjtable [2] 

0.07; 

index stable [ 3 ] 

0.25; 

index_table [4 ] 

0.35; 

index stable [ 5 ] 

0.5; 

index stable [ 6 ] 

1.0; 

index_table [7] 

«- 

1.47; 

index_table[8] 

:  - 

1.5; 

index_table [ 9] 

2.0; 

index jt able [10] 

2.5; 

index_table [11] 

*" 

3.0; 

index_table [12] 

3.5; 

index_table[13] 

»- 

4.0; 

index_table[14] 

:« 

4.393; 

index_table[15] 

4.394; 

index _t able [16] 

9.9995; 

tf_table(l]  :• 

3.3385E4; 

tf_table [2 ]  : 

-  3. 

.  S891E4 ; 
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tf_table[3] 

4.2332SE4; 

tf_table[4] 

4.59115E4 

tf_table(5] 

S-  5.128E4; 

tf_table [6] 

5.179E4; 

tf_table [7] 

5.1527E4; 

tf_table [8] 

5.151E4; 

tf_table[9] 

5.1025E4; 

tf— table [10] 

5.0305E4; 

tf_table(ll] 

5.001E4; 

tf_table[12] 

:« 

5 . 0305E4; 

tf— table [13] 

5 . 051SE4; 

tf_table [14] 

!- 

5.065E4; 

tf_table[15] 

0.0; 

tf__table  [16] 

0.0; 

for  count 

2  to  mun_point3 

do 

diff_t able (count]  (tf_table [count]  -  tf_table [count-1] )  / 

(index_table [count]  -  index_table [count-1] ) ; 

end;  [  Procedure  Initialize_table  } 


Procedure  pivot (  var  ihigh,  ilow  :  integer;  search_value  :  real  )? 

var 

ipiv  :  integer; 

begin 

while  ( (ihigh  -  ilow)  >  1)  do  begin 
ipiv  :**  (ihigh  +  ilow)  div  2; 

if  search_value  -  index_table[ipiv]  then  begin 
ilow  i-  ipiv; 
ihigh  ilow  +1? 

end 

else  if  search_value  <  index_t able [ipiv]  then 
ihigh  ipiv 

else 

ilow  ; -  ipiv; 

end; 

end;  {  Procedure  pivot  ) 


Function  search_table (  search_value  ;  real  )  :  integer; 

var 

ihigh, 

ilow  ;  integer; 

begin 

ilow  :«  low_last; 
ihigh  :«  high_last; 

if  (search_value  >  index_table [ilow} )  and 

(search_value  <  index_table [ihigh] )  then  begin 
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pivot <  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  -  index_t able [ilow]  then  begin 
ihigh  ilow  +1; 

end 

else  if  search_value  -  index_table [ihigh]  then  begin 
ilow  ihigh; 

ihigh  ilow  +  1? 

end 

else  if  search_value  <  index_table(l]  then  begin 
ihigh  s-  2; 
ilow  s-  1; 

end 

else  if  search_value  >  index^tabletnumjaoints]  then  begin 
ihigh  ;•  nura_points; 
ilow  ihigh  -  1; 

end 

else  if  search_value  >  index_table  [ihigh]  then  begin 
ihigh  nura_points; 
pivot  (  ihigh,  ilow,  search__value  ) ; 

end 

else  if  search^value  <  index^tabletilow]  then  begin 
ilow  1; 

pivot t  ihigh,  ilow,  search_value  ); 

end; 

low^last  ilow; 

high_last  ihigh; 

search_table  ihigh; 
end;  {  Function  search_table  J 


Procedure  Eva luate_t able (  time  :  real  ) ; 

{ 

Table  TF  -  Block  1 

) 

var 

sub_index, 

index  :  integer; 

tf  :  real; 

begin 

index  search_table (  time  ) ; 
sub_index  index  -  1; 
tf  tf_tabletsub_index]  + 

(dif f_table t index]  * 

<time  -  index_table [sub_index] ) ) ; 
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File:  BLOCK02.PAS 

Module  Problera_Specifications; 

Public  Problera_Specifications; 

Procedure  InitializeJTable; 

Procedure  EvaluateJTable (  time  :  Real  ); 

Public  Solve_Table; 

Var  time,  integration_step  :  Real; 

$Include  (' : PFP: include ft arget. pas  * ) 

Private  Problem_Specifications; 

const 

num_points  -  16; 


low_last, 

high_last  :  integer; 

riyf^table  :  array  (1 . .num_points]  of  real; 
index_table  :  ‘array  [1 .  .num__points]  of  real; 
diff^table  :  array  [1 . ,num_points]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

message_type,  message_size  ;  integer; 

begin 

input_message (  me3sage_type,  integration_step,  message^size  ); 

low_last  1; 
high_last  numjpoints; 


index_table [ 1 I 

0.0; 

index_table[2] 

0.07; 

indexj:able[3] 

m 

CM 

o 

index_table [41 

t« 

0.35; 

index_table { 5 ] 

0.5; 

index_table[6] 

1.0; 

index_table [7] 

1.47; 

index_table [8 ] 

1.5; 

index_table [ 9 ] 

2.0; 

index_table[10] 

2.5; 

index_table[llj 

3.0; 

index_table [12  ] 

3.5; 

index_table[13] 

4.0; 

index_table [ 14 ] 

4  .393; 

index_table[15] 

4.394; 

index_table [16] 

9.9995 

riyf__table  [1]  49.05E-5;  riyf_table [2]  49.089E-5; 


-  49.19E-5; 


-  49.246E-5; 


riyf_table[3] 
riyf_table[5]  :»  49.33E-5; 
riy ratable [-71  50.031E-5 

riyf_table [ 91  :■  50.45E-5; 

riyf_table[ll]  51.16E-5; 
riyf_t  able  [131  2"  S2.78E-5; 
riyf_table[15]  S3.45E-S; 


riyf_table[41 
riyf_table[6]  49.66E-S; 

riyf_table[8]  50.055E-5; 

riyf_table [10]  s-  50.805E-5; 
riyf_table [12]  51.97S-5; 

riyf_table(14]  :•  53.4SE-5; 
riyf_table[16}  53.4SE-5; 


for  count  2  to  nura__points  do 

diff  table [count]  (riyf_table[ count]  -  riyf_table [count-1] )  / 
( index_t able [ count  1  -  index_table  [count-1] ) 


end;  {  Procedure  Initialize_table  } 


Procedure  pivot (  var  ihigh,  ilow  :  integer;  seareh_value  :  real  ); 

var 

ipiv  s  integer; 

begin 

while  ( [ihigh  -  ilow)  >  1)  do  begin 
ipiv  :«■  (ihigh  +  ilow)  div  2; 

if  search_value  -  index_table(ipiv]  then  begin 
ilow  ipiv; 
ihigh  ilow  +  1; 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  ipiv 

else 

ilow  ipiv; 

end; 

end;  {  Procedure  pivot  ) 


Function  search_table (  search_value  j  real  )  :  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table [ilow] )  and 

[seareh_value  <  index_table [ihigh] )  then  begin 
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pivot (  ihigh,  ilow.  search_value  ); 


end 

else  if  search_value  -  index_table (ilow]  then  begin 
ihigh  s-  ilow  +1; 

end 

else  if  search_value  -  index^t able [ihigh]  then  begin 
ilow  :•  ihigh; 
ihigh  :«  ilow  +  1; 

end 

else  if  search_value  <  index_table [ 1 ]  then  begin 
ihigh  :«  2; 
ilow  1; 

end 

else  if  search_value  >  index_table[num_points]  then  begin 
ihigh  num_points; 
ilow  ihigh  -  1; 

end 

else  if  search_value  >  index_table [ ihigh ]  then  begin 
ihigh  :«■  nura_jpoints; 
pivot {  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  <  index_table[ilow]  then  begin 
ilow  1; 

pivot {  ihigh,  ilow,  search_value  ); 

end; 

low_last  ilow; 

high_last  ihigh; 

search_table  ihigh; 
end;  {  Function  search_table  > 


Procedure  Evaluate_table (  time  :  real  ); 

( 

Table  RIYF  -  Block  2 

) 

var 

sub_index, 

index  ;  integer; 

riyf  s  real; 

begin 

index  :«  search_table (  time  ); 
sub_index  index  -  1; 
riyf  riyf_table ( sub_index]  + 
(diff_table [index]  * 

(time  -  index_table [sub_index] ) ) ; 


Send_Real_32bit (  riyf  ); 


end; .  {  Procedure  Evaluate_table  ) 
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File:  BLOCK 03 .PAS 

Module  Problera_Specifications; 

Public  Problera_Specifications; 

Procedure  Initialize_Table; 

Procedure  Evaluate_Table {  time  :  Real  ) ; 

Public  Solve_Table; 

Var  time,  integration_step  :  Real; 

$ Include  ( ' : PFP : include/target . pas  * ) 

Private  Problera_Specifications; 


const 

nurajpoints  -  16; 

var 

low_last, 

high_last  :  integer; 


lclcgf_table 
index_table 
diff  table 


array  (1 . .num_points]  of  real; 
array  [1. .nurajpoints]  of  real; 
array  [1 . .nurajpoints]  of  real; 


Procedure  Initialize^table; 

var 

count  :  integer; 

message_type,  message_size  :  integer; 

begin 

input jne ss age (  message_type,  integration_step,  message_size  ); 

low_last  1; 
high_last  nura_j?oints; 


index_table[lj 

0.0; 

index_table[2] 

s- 

o 

o 

-J 

index_table[3] 

0.25; 

index_table [4] 

0.35; 

index_table [ 5 ] 

0.5; 

index_table [6] 

1.0; 

index_table [7] 

*• 

1.47; 

indexjiable [8] 

1.5; 

index_table[9] 

2.0; 

index_table [10] 

2.5; 

index _table  f 1 1 ] 

3.0; 

index_t able [12] 

3.5; 

index_table [13] 

4.0; 

index_table [14 ] 

4.393; 

index_table [15] 

4.394; 

index_table [16] 

9.9995 

6.75; 


lclcgf_table [1] 


lclcgf_table [2]  6.7495; 
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lclcgf_table [3]  6.7483; 

ldcgf_table  [  5  ]  6.7465; 

lclcgf_table I 7 ]  :«  6.7651; 

lclcgf_table[9l  6.79; 

lclcgf_table ( 11  ]  6.891; 

lclcgfj:able[13]  7.098; 

lclcgf_table[15]  7.18; 


lclcgf_table[4]  6.7476; 

lclcgf__table  [6]  s-  6.743; 
lclcgf_table[8]  6.7665; 

lclcgf_table [10]  6.8405; 

lclcgf_table[12]  6.9945; 

lclcgf_table[14]  7.18; 

lclcgf_table [16]  7.18; 


for  count  2  to  num_points  do 

diff__t able  [count]  <lclcgf__table  [count  J  -  lcl eg f_table  [count-1] )  / 

(index_table [count]  -  index_table [ count- 1 ] ) ; 

end;  [  Procedure  Initialize_table  } 


Procedure  pivot {  var  ihigh,  ilow  ;  integer;  search_value  s  real  ); 

var 

ipiv  :  integer; 

begin 

while  < (ihigh  -  ilow)  >  1)  do  begin 
ipiv  < ihigh  +  ilow)  div  2; 

if  seareh_value  -  index_table[ipiv]  then  begin 
ilow  s-  ipiv; 
ihigh  ilow  +1; 

end 

else  if  search_value  <  index^t able [ipiv]  then 
ihigh  ipiv 

else 

ilow  ipiv; 

end; 

end;  (  Procedure  pivot  ) 


Function  search_table(  search_value  :  real  )  :  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search^ value  >  index_table [ilow] )  and 

<search_value  <  index_table [ihigh] )  then  begin 
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pivot (  ihigh,  ilow,  search_value  ) ; 


end 

else  if  search__value  -  index_table [ilow]  then  begin 
ihigh  ilow  +1; 

end 

else  if  search_value  -  index_table [ihigh]  then  begin 
ilow  :«•  ihigh; 
ihigh  ilow  +  1; 

end 

else  if  search_value  <  index^tabledJ  then  begin 
ihigh  2; 

ilow  1; 

end 

else  if  search^value  >  index_table[num_points]  then  begin 
ihigh  nura^points; 
ilow  :•  ihigh  -  1? 

end 

else  if  search_value  >  index_table [ihigh]  then  begin 
ihigh  nuio_jjoints; 

pivot (  ihigh,  ilow,  search_value  ) ? 

end 

else  if  search_value  <  index_table [ilow]  then  begin 
ilow  s-  1* 

pivot <  ihigh,  ilow,  search_value  ); 

end; 

low_last  ilow; 

high_last  ihigh; 

search_table  ihigh; 
end;  {  Function  sear ch_t able  ] 


Procedure  Bvaluate_table (  time  :  real  ); 
{ 

Table  LCLCGF  -  Block  3 


var 

sub_index, 

index  s  integer; 

lclcgf  :  real; 

begin 

index  search_table (  time  ); 
sub_index  index  -  1; 
lclcgf  lclcgf__table  [sub_index]  + 
(diff_table [index]  * 

(time  -  index_table [ sub_index] ) ) ; 
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Send_Real_32btt (  lclcgf  ) ; 


end;.  (  Procedure  Bvaluate_table  } 
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File:  BLOCK04 .FAS 

Module  Problera_Specifications; 

Public  Problera_Specifications; 

Procedure  Initialize_Table; 

Procedure  Evaluate_Table {  time  :  Real  ); 

Public  Solve_Table; 

Var  time,  integration_step  :  Real; 

^Include  (' :PFP : include/target. pa s’ ) 

Private  Problera__Specifications; 

const 

nura_points  -  16; 

var 

low_last, 

high^last  :  integer; 

ltf_table  :  array  [1. .num_pointsI  of  real; 

index_table  :  array  [1 . .nurajpointsl  of  real; 

diff_table  :  array  [1 . ,num_points]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

message_type,  mes9age_size  :  integer; 

begin 


input ^message (  message_type 

low_last  1; 

high_last  num_points; 

,  integration_step. 

message_size 

index_table [ 1 ] 

0.0; 

index_tablet2] 

0.07; 

index_jtable  [3] 

0.25; 

index_table[4] 

:  “ 

0.35; 

index_table(5] 

0.5; 

index_table(6] 

1.0; 

index_table [ 7 ] 

1.47; 

index_table[8] 

1.5; 

index_table [9] 

2.0; 

index_table [10] 

2.5; 

index_table[ll] 

3.0; 

index_table [12] 

3.5; 

index_table[13] 

4.0; 

index_table [14 ] 

t- 

4.393; 

index_table[15] 

4.394; 

index_table [16] 

9.9995; 

ltf_table [1]  : 

-  193.4; 

ltf_table [2] 

220.0  ; 
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It f— table [3] 

260.0; 

ltf_table[4] 

260.0; 

ltf_table[5] 

237.5; 

ltf_table[6] 

160.42 

ltftable[7] 

60.0; 

ltf_table[8] 

j-  0.0; 

It  f__table  [9] 

0.0; 

ltf_table[10] 

0.0; 

ltf_table[U1 

0.0; 

ltf_table[12] 

0.0; 

ltf— table [13] 

0.0; 

ltf_table[14] 

0.0; 

ltf_table [15] 

0.0; 

ltf_table [16] 

0.0; 

for  count 

2  to  nurajpoints  do 

diff  tablefcount]  s-  (ltf_table [count]  -  ltf_table [count-1] )  / 

(index_table [count !  -  index_table [count-1 ] ) ; 


end;  {  Procedure  Initialize_table  } 


Procedure  pivot <  var  ihigh,  ilow  t  integer;  search_value  :  real  ); 

var 

ipiv  :  integer; 

begin 

while  ([ihigh  -  ilow)  >  1)  do  begin 
ipiv  (ihigh  +  ilow)  div  2; 

if  search_value  -  index_table[ipiv]  then  begin 
ilow  ipiv; 
ihigh  ilow  +  1; 

end 

else  if  search_value  <  index_table[ipiv]  then 
ihigh  ipiv 
else 

ilow  ipiv; 

end; 

end;  (  Procedure  pivot  ) 


Function  search_table (  search_value  :  real  )  :  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table [ilow])  and 

(search_value  <  index^table [ihigh] )  then  begin 
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pivot (  ihigh,  ilow,  search_value  ) ; 


end 

else  if  search_value  -  index_t able [ilow]  then  begin 
ihigh  ilow  +  1? 

end 

else  if  search_value  -  index_table[ ihigh]  then  begin 
ilow  :**  ihigh; 
ihigh  s-  ilow  +1; 

end 

else  if  search_value  <  index_table[l]  then  begin 
ihigh  s-  2; 
ilow  1; 

end 

else  if  search_value  >  index_table [nura_points]  then  begin 
ihigh  num_points; 
ilow  ihigh  -  1; 

end 

else  if  search_value  >  index_table [ihigh]  then  begin 
ihigh  num_points; 
pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  <  index_t able [ilow]  then  begin 
ilow  1; 

pivot (  ihigh,  ilow,  search_value  ); 

end; 

low_last  ilow; 

high_last  s-  ihigh; 

search_table  ihigh; 
end;  {  Function  search_table  ] 


Procedure  Evaluate_table {  time  :  real  ); 
{ 

Table  LTF  -  Block  4 


var 

sub_index, 

index  :  integer; 

ltf  :  real; 

begin 

index  search_table {  time  ); 
sub_index  index  -  1; 
ltf  :•  ltf_table [sub_index]  + 
(diff_table[ index]  * 

(time  -  index_table  [sub_index] ) ) ; 


Send_Real_32bit (  ltf  ); 
end; .  {  Procedure  Evaluate_table  ) 
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File:  BLOCKOS.PAS 

Module  Problen_Specifications? 

Public  Problem_Specifications; 

Procedure  Initiali2e_Table; 

Procedure  Evaluate__Table(  tine  :  Real  ); 

Public  Solve_Table; 

Var  tine,  integration_step  :  Real; 

$Include  (* :PFP : include/target. pas’ ) 

Private  Problen_Specifications; 

const 

nunjpoints  -  16; 

var 

low_last, 

high_last  :  integer; 

acdOf^table  :  array  [1 .  .nun_jsoints]  of  real; 
index_table  :  array  (1 . .nura_points]  of  real; 
diff_table  :  array  [1 . .nun_points]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

message_type,  message_size  :  integer; 

begin 

input_message {  nessage_type,  integration_step,  message_size  ); 

low_last  1; 
high_last  nunjpoints; 


index_table[l] 

0.0; 

index_table(2] 

0.8; 

index_table [3] 

1.2; 

index_table ( 4  ] 

1.5; 

index_table [5] 

1.6; 

index_table[6] 

1.7; 

index_table [7] 

S" 

1.8; 

index_table { 8 ] 

2.0; 

index_table [9] 

2.1; 

index_table [10] 

2.3; 

index^t able [11] 

2.5; 

index_table { 12] 

2.7; 

index_table [13] 

3.0; 

index_table [14] 

3.5; 

index_table [15] 

8- 

4.394; 

index_table [16] 

9.9995; 

acdOf_table [1] 

.. 

9.625E-2, 

acdOf__table  [2]  7. 
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acdO  f_t  able  [  3  ] 

!- 

6.235E-2; 

acd0f_table{4] 

s-  5.63E-2; 

acdO  f_table [ 5 ] 

6.185E-2; 

acd0f_table[6] 

7.72E-2; 

acd0f_table[7] 

9.25E-2; 

acdOf_table [8] 

1.307E-1; 

aed0f_table[9] 

s- 

1.4155E-1; 

acd0f_table[10] 

1.3725E-1 

acdO f_t able (11] 

1.274E-1; 

acdO  f_table  [  12  ] 

1.201E-1; 

acd0f_table[13] 

1.0915E-1; 

acdO f_t able [ 14 ] 

9.785E-2; 

acdOf_table [15] 

8 .335E-2; 

acdO ratable [16] 

8.335E-2; 

for  count  2  to  nurajpoints  do 

diff_table [count]  (acdOf_t able [count]  -  acdOf_table [count-1] ) 
(index_t able [count]  -  index_t able [count-1] ) 


end?  {  Procedure  Initial! ze_table  } 


Procedure  pivot <  var  ihigh,  ilow  :  integer;  search_value  ;  real  ); 

var 

ipiv  :  integer; 

begin 

while  ((ihigh  -  ilow)  >  1)  do  begin 
ipiv  s-  (ihigh  +  ilow)  div  2; 

if  aearch_value  -  index_table [ipiv]  then  begin 
ilow  ipiv; 

ihigh  ilow  +1; 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  ipiv 

else 

ilow  ipiv; 

end; 

end;  {  Procedure  pivot  > 


Function  search_table (  search_value  :  real  )  :  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table [ilow] )  and 

(search  value  <  index_t able [ihigh] )  then  begin 


pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  -  index_t able [ilov]  then  begin 
ihigh  ilow  +  1; 

end 

else  if  search_value  -  index_table [ihigh]  then  begin 
ilov  :•  ihigh; 
ihigh  ilow  +1; 

end 

else  if  search_value  <  index_table [1]  then  begin 
ihigh  2; 

ilow  i-  1; 

end 

else  if  search_value  >  index_table [num_points]  then  begin 
ihigh  num_points; 
ilow  ihigh  -  1; 

end 

else  if  search^value  >  index_table [ihigh]  then  begin 
ihigh  nura_points; 

pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  <  index_t able [ilow]  then  begin 
ilow  1; 

pivot (  ihigh,  ilow,  search_value  ) ; 

end; 

low_last  ilow; 

high_last  ihigh; 

sear ch_t able  ihigh; 

end;  {  Function  search_table  ) 


Procedure  Evaluate_table (  time  :  real  ) ; 

< 

Table  ACDOF  -  Block  5 

var 

sub_index, 

index  s  integer; 

acdOf  ;  real; 

begin 

index  search_table (  time  ); 

sub_index  index  -  1; 
acdOf  acdOf_table[sub_index]  + 

(diff_table [index]  * 

(time  -  index_table[sub_index] ) ) ; 
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File:  BLOCK06.PAS 

Module  Problera_Specifications; 

Public  Problem_5pecifications; 

Procedure  Initialize_Table; 

Procedure  Evaluate_Table (  time  :  Real  ); 

Public  Solve_Table; 

Var  time,  integration_3tep  :  Real; 

^Include  ( * :PFP : include/target .pas * ) 


Private  Problem_specifications; 


const 

num_points  -  16; 


low_last, 

high_last  :  integer; 


cmaf_table 

index_table 

diff__table 


array  [1 . .nura_points]  of  real; 
array  [1. .nura_points]  of  real; 
array  tl • .num_points]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

message_type,  message_size  :  integer; 

begin 


input_message  (  message_type,  integration_step,  message__size  ) 

lov^last  1; 
high_last  nura_points; 


index_table [1] 

s- 

0.0; 

index_table[2] 

0.8; 

index_table [3] 

1.2; 

index_table[4] 

1.5; 

index_table [5] 

s- 

1.6; 

index_table [6] 

1.7; 

index_table [7] 

i- 

1.8; 

index_table[8] 

2,0; 

index_table [9] 

2.1; 

index_table [101 

2.3; 

index_table[ll] 

:  •* 

2.5; 

index_table [12] 

2.7; 

index_table [13 ] 

3.0; 

index_table [14] 

i- 

3.5; 

index_table[15] 

4.394; 

index_table [16] 

9.9995; 

cmaf_table [1] 

- 

-7.5925; 

cmaf__table  [2] 

-9.8925 
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caaf_table[3] 

s- 

-8.9775; 

craaf_table[4] 

-6.2; 

cmaf_table [5] 

s- 

-4.8225; 

cmaf_table[6] 

-3.805; 

cmaf _table [7] 

-4.235; 

onaf_table[8] 

-6.355; 

cmaf_table[9] 

«- 

-7.48; 

cmaf_table [10] 

-8.655; 

cmaf_table [11] 

-8.385; 

cma  f _table [12] 

-7.715; 

cmaf_table [13] 

S" 

-6.21; 

anaf_table[14] 

-3.945; 

cmaf_table(15] 

-1.655; 

cmaf_table  [16] 

-1.655; 

for  count  2  to  nurajpoints  do 

difff  table[count]  (cmaf_t able [count]  -  emaf_table [count-i] )  / 

(index^t able [count]  -  index_t able [count -1] ) 

end;  {  Procedure  Initializ eatable  ] 


Procedure  pivot <  var  ihigh,  ilov  :  integer;  search_value  ;  real  ); 

var 

ipiv  ;  integer; 

begin 

while  ({ihigh  -  ilow)  >  1)  do  begin 
ipiv  : —  (ihigh  +  ilow)  div  2; 
if  search_value  -  index_t able [ipiv]  then  begin 
ilow  ipiv; 

ihigh  ilow  +  1; 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  ipiv 

else 

ilow  ipiv; 

end; 

end;  (  Procedure  pivot  ) 


Function  search_table (  search_value  :  real  )  :  integer; 

var 

ihigh, 

ilow  ;  integer; 

begin 

ilow  low_last; 
ihigh  :*■  high_last; 

if  <search_value  >  index_table [ilow] )  and 

(search_value  <  index__table [ihigh] )  then  begin 
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pivot {  ihigh,  ilow,  search_value  ); 


end 

else  if  search_value  -  index_table (ilow]  then  begin 
ihigh  :•  ilow  +1; 

end 

else  if  search^ value  -  index_t able [ihigh]  then  begin 
ilow  ihigh? 
ihigh  ilow  +1; 

end 

else  if  search_value  <  index_table [11  then  begin 
ihigh  2; 

ilow  1; 

end 

else  if  search__value  >  index_table [nura_points]  then  begin 
ihigh  nura_points; 

ilow  ihigh  -  1; 

end 

else  if  search_value  >  index_table [ihigh]  then  begin 
ihigh  nurajpoints; 

pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  <  index_table [ilow]  then  begin 
ilow  If 

pivot (  ihigh,  ilow,  search^value  ) ; 

end; 

low_last  j-  ilow; 

high_last  ihigh; 

search_table  ihigh; 
end;  {  Function  search_table  } 


Procedure  Evaluate_table (  time  :  real  ) ; 

{ 

Table  CMAF  -  Block  6 

1 

var 

sub_index , 

index  :  integer; 

cmaf  s  real; 

begin 

index  search_table (  time  ); 
sub_index  :«  index  -  1; 
cmaf  cmaf_table [sub_index]  + 
(diff_table [index]  * 

(time  -  index_table [sub_index] ) ) ; 


Send  Real_32bit(  cmaf  ); 


end; .  {  Procedure  Eva luate__t able  } 
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File:  BLOCK07 .PAS 

Module  Problera_Specifications; 

Public  Problera_Specifications; 

Procedure  Initialize_Table; 

Procedure  Evaluate_Table (  time  :  Real  ) ; 

Public  SolveJTable; 

Var  time,  integration^step  :  Real; 

$Include  ( * :PFP : include/target .pas’) 

Private  Problem_Specifications; 

const 

nurajpoints  -  16; 

var 

low_last, 

high_last  :  integer; 

craqf_table  :  array  [1 . ,num_points]  of  real; 
index_table  :  array  (1 .  .nura_j>oints]  of  real; 
diff_table  :  array  fl. .nurajpoints]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

measage_type,  raessage_size  :  integer; 

begin 

input_message (  message_type,  integration_step,  message_size  ); 

low_last  1; 
high_last  nura_point3; 


index_table [1] 

0.0; 

index_table(2] 

0.8; 

index_table [3] 

1.2; 

index_table [4] 

1.5; 

index_table [5] 

1.6; 

index_table(6] 

1.7; 

index_table[7] 

1.8; 

index stable [ 8 ] 

2.0; 

index_table [9] 

2.1; 

index_table (10] 

2.3; 

index_table[ll] 

2.5; 

index_table [ 12 ] 

2.7; 

index_table ( 13 ] 

3.0; 

index_table(14] 

3.5; 

index_table (15] 

4.394; 

index_table [16] 

9.9995; 

cmqf_table [ 1 ] 

: - 1054.4; 

cmqf stable [2] 

- - 1094. 
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cmqftable[3] 

-1114.0; 

cmqf_table[4] 

-1060.0 

cmqf_table[5] 

-1035.2; 

croqf_table [6] 

-1010.8 

craqf_table[7] 

!* 

-986.0; 

cmqf_table [8] 

-936.8; 

cmqf_table  [9] 

-938.8; 

anqf_table[10] 

-940.8; 

cmqf_table[ll] 

-960.0; 

cmqf_table[12] 

-981.2; 

cnqf_table[13] 

-1013.2; 

craqf__table  [14] 

-972.4; 

cmqf_table[15] 

-878.8; 

cmqf_table [16] 

!• 

-878.8; 

for  count  2 

to 

nurajpoints 

do 

dif f_table [count]  (cmqf_table[ count]  -  cmqf_t able [count-1] )  / 

(index_table (count]  -  index_table [count-1] ) 

end;  {  Procedure  Initialize_table  ) 


Procedure  pivot (  var  ihigh,  ilow  :  integer;  search_value  :  real  ); 

var 

ipiv  :  integer; 

begin 

while  ((ihigh  -  ilow)  >  1)  do  begin 
ipiv  s-  (ihigh  +  ilow)  div  2; 

if  search_value  -  index_t able [ipiv]  then  begin 
ilow  s-  ipiv; 
ihigh  ilow  +1; 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  :«  ipiv 

else 

ilow  ipiv; 

end; 


end;  {  Procedure  pivot  ) 


Function  search_table (  search_value  ;  real  )  :  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table [ilow] )  and 

(search_value  <  index_table [ihigh] )  then  begin 
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pivot {  ihigh,  ilow,  searchjvalue  ); 


end 

else  if  search_value  -  index_table[ilov]  then  begin 
ihigh  :«  ilow  +  1; 

end 

else  If  search_value  -  index_table [ihigh]  then  begin 
ilow  ;•  ihigh; 
ihigh  ilow  +1; 

end 

else  if  search_value  <  index_table [ 1 ]  then  begin 
ihigh  2: 

ilow  s-  1; 

end 

else  if  search_value  >  index^table  [nurajpoints]  then  begin 
ihigh  nura_points; 

ilow  :«  ihigh  -  1; 

end 

else  if  search_value  >  index_table [ihigh]  then  begin 
ihigh  nura_points; 

pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  search__value  <  index^table  [ilow]  then  begin 
ilow  1? 

pivot (  ihigh,  ilow,  search_value  ); 

end; 

low^last  j-  ilow; 

high_last  ihigh; 

search_table  ihigh; 
end;  {  Function  search__table  ] 


Procedure  Evaluate_table (  time  :  real  ) ; 

{ 

Table  CMQF  -  Block  7 

} 

var 

sub_index, 

index  s  integer; 

cmqf  :  real; 

begin 

index  3earch_table (  time  ); 

3ub_index  index  -  1; 
cmqf  cmqf_table [sub_index]  + 
(diff_table [index]  * 

(time  -  index_table [ sub_index] ) ) ; 
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File:  BLOCK08.PAS 

Module  Problem_Specifi cat ions; 

Public  Problera_Specifications; 

Procedure  Initialize_Table; 

Procedure  EvaluateJTable {  time  :  Real  ) ; 

Public  Solve_Table; 

Var  time,  integration_step  :  Real; 

$ Include  ( * ; PFP : include/ tar get .pas') 

Private  Problem_Specifications; 

const 

nura^points  *»  8; 
zO  -  3990.0; 


low_last, 

high_last  :  integer; 


wnsf_table 
index_table 
diff  table 


array  [1 . .nura_points]  of  real; 
array  [1. .nura_points]  of  real; 
array  [1 .  .nura_jjointsl  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

raessage__type,  message_size  :  integer; 

begin 

input_message(  raessage_type,  integration_step,  rnessage_size  ); 

low_last  1; 
high_last  nurajpoints; 


index_table [1] 

0.0; 

index_table [2] 

-  2.0E3; 

index_table(3] 

3.7E3; 

index_table(4] 

-  4.0E3; 

index_table [5] 

6.0E3; 

index_table [6] 

-  8.0E3; 

index_table [7] 

10.0E3; 

index_table [8] 

-  12.0E3; 

wnsf_table [1] 

1.175; 

wnsf_table [2] 

0.53986; 

wnsf_table [3] 

i- 

0.0; 

wnsf_table [4 ] 

: - 0.09524 

wnsf_table (5) 

-0.73016; 

vnsf_table (6) 

:■ - 1.36508 

wnsf_table [7] 

:« 

-2.0; 

wnsf_table [8] 

-2.63492 

for  count  2  to  numjpoints  do 

di f f_t ablet count ]  <wnsf_table [count]  -  wnsf_table [count-1] )  / 

(index_t able [count]  -  index_table [count-1] ) 

end;  {  Procedure  Initialize_table  } 


Procedure  pivot (  var  ihigh,  ilow  :  integer;  search_value  :  real  ); 

var 

ipiv  :  integer; 

begin 

while  ( (ihigh  -  ilow)  >  1)  do  begin 
ipiv  (ihigh  +  ilow)  div  2: 

if  search_value  -  index_table[ipiv]  then  begin 
ilow  ipiv; 
ihigh  ;«  ilow  +■  1; 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  ipiv 

else 

ilow  ipiv; 

end; 

end;  {  Procedure  pivot  > 


Function  search_table (  search_value  :  real  )  :  integer; 

var 

ihigh , 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  <search_value  >  index_table [ilow] )  and 

(search_yalue  <  index_table [ihigh] )  then  begin 
pivot {  ihigh,  ilow,  search_value  ); 

end 

else  if  search__value  -  index_table [ilow]  then  begin 
ihigh  ilow  +  1; 

end 

else  if  search_value  -  index_table [ihigh]  then  begin 


Digital  Emulation  Technology  Laboratory  Final  Report 


ilow  ihigh; 

ihigh  ilow  +1; 

end 

else  if  search_value  <  index_table(l]  then  begin 
ihigh  :•  2: 
ilow  :«  1; 

end 

else  if  search_value  >  index_table  [numjpointsl  then  begin 
ihigh  nura^points; 
ilow  ihigh  -  1; 

end 

else  if  seareh_value  >  index_table [ ihigh J  then  begin 
ihigh  nurajpoints; 
pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  <  index_t able [ilow]  then  begin 
ilow  :«*  1; 

pivot (  ihigh,  ilow,  search_value  ) ; 

end; 

low_last  ilow; 

high_last  ihigh; 

search_table  ihigh; 
end;  {  Function  sear ch_t able  > 


Procedure  Evaluate_table (  time  :  real  ) ; 

i 

Table  WNSF  -  Block  8 

) 

var 

sub_index,. 

index  :  integer; 

z, 

zprime, 

wnsf  :  real: 

begin 

Receive_Real  J32bit <  z  ) ; 

zprime  z  +  z 0; 

index  search_table {  zprime  ); 

sub_index  :«  index  -  1; 

wnsf  wnsf_table[sub_indexl  + 

(diff_table ( index 1  * 

(zprime  -  index_table [sub^index] ) ) ; 
Send_RealJ32bit (  wn3f  ); 

end; .  (  Procedure  Evaluate_table  } 


File:  BLOCK09 .PAS 

Module  Problera_Specifications; 

Public  Problem_Speeif ications ; 

Procedure  Initialize_Table; 

Procedure  Evaluate_Table (  time  :  Real  ) ; 

Public  Solve  JTable; 

Var  time,  integration_step  :  Real; 

^Include  ( * :PFP : include/target .pas ' ) 

Private  Problera_Specifications; 

const 

nura_points  -  8: 

*0  -  3990.0; 

var 

low_last, 

high_last  :  integer; 

wef_table  :  array  [1. .nura_pointsl  of  real; 

index_table  :  array  [1. .num_points]  of  real; 

diff— table  :  array  (1 • .num_points]  of  real; 


Procedure  Initial! ze_t able; 

var 

count  :  integer; 

me3sage_type,  message_sire  :  integer; 
begin 

input  jnes sage (  message_type,  integration_step,  message_size  ) 

low_last  1; 
high_last  nura_points; 


index_table[l] 

0.0; 

index_table[2] 

-  2.0E3; 

index_table[3] 

3.7E3; 

index_table[4] 

-  4.0E3; 

index_table [5 ) 

*- 

6.0E3; 

index_table [6] 

-  8.0E3; 

index_table[7] 

10.0E3; 

index_table [ 8 ] 

-  I2.0E3 

wwef^table ( 1] 

-2.0; 

wwef_table {2] 

-2.0; 

wwef_table [3] 

-2.0; 

wwef  table [4]  :« 

-2.0; 

wef_table  [5] 

-2.0; 

wwef_table{6] 

-2.0; 

wwef_table [7] 

-2.0; 

wwef_table [ 8 ] 

-2.0; 
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for  count  2  to  numjpoints  do 

diff_t able [count]  (wwef_t able [count]  -  wwef_table [count-1] )  / 

(index_table[ count]  -  index_table [count-1] ) ; 

end;  {  Procedure  Inltialize_table  ) 


Procedure  pivot (  var  ihigh,  ilow  ;  integer;  search_value  :  real  ); 

var 

ipiv  :  integer; 

begin 

while  ((ihigh  -  ilow)  >  1)  do  begin 
ipiv  (ihigh  +  ilow)  div  2; 
if  search__value  -  index_table(ipiv)  then  begin 
ilow  ipiv; 
ihigh  :«  ilow  +1; 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  :«  ipiv 
else 

ilow  j»  ipiv; 

end; 

end;  {  Procedure  pivot  } 


Function  search_table (  search_value  :  real  )  :  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table (ilow) )  and 

(search_value  <  index_table ( ihigh ] )  then  begin 
pivot (  ihigh,  ilow,  search^value  ) ; 


end 

else  if  search^value  -  index_table [ilow]  then  begin 
ihigh  ilow  +  l; 

end 

else  if  search_value  -  index^table [ihigh]  then  begin 
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ilow  ihigh; 

ihigh  ilow  +  1; 

end 

else  if  search_value  <  index_table [1]  then  begin 
ihigh  2; 

ilow  1; 

end 

else  if  search_value  >  index_table [numjpoints]  then  begin 
ihigh  numjpoints? 

ilow  ihigh  -  1; 

end 

else  if  searchjValue  >  index_t able (ihigh]  then  begin 
ihigh  numjpoints; 
pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  searchjValue  <  index_table (ilow]  then  begin 
ilow  1; 

pivot (  ihigh,  ilow,  search^value  )? 

end? 

low_last  ilow: 

high_last  ihigh; 

search__table  ihigh; 
end;  {  Function  search^table  } 


Procedure  Eva luate_t able (  time  :  real  ) ; 

( 

Table  WWEF  -  Block  9 

> 

var 

subjindex, 

index  :  integer; 

z, 

zprime , 

wwef  :  real; 

begin 

Receive_RealJ32bit (  z  ) ; 

zprime  z  +  zO; 

index  search_table (  zprime  ); 

subjindex  :«  index  -  1? 

wwef  wwef_table (subjindex]  + 

<diff_table{ index]  * 

(zprime  -  index_table [sub_index] ) ) ; 
Send  Real  32bit(  wwef  ); 


end;.  {  Procedure  Evaluate _table  } 
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Files  BLOCK1 0 . PAS 

Module  Problera_Specifications; 

Public  Problem_specifications; 

Procedure  Initialize_Table; 

Procedure  Evaluate_Table (  time  ;  Real  ) ; 

Public  Solve_Table; 

Var  time,  integration_step  :  Real; 

$Include  (*  sPFPsinclude/target.pas’ ) 

Private  Problem_Specification3; 

const 

nurajpoints  -  8; 
zO  -  3990.0; 


var 

lov__last, 

high_last  s  integer; 

rhof_table  j  array  [1 . .nura_points]  of  real? 
index_table  :  array  [1 . .nura_points]  of  real; 
diff_table  :  array  (1. .nurajpoints]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

message _type,  message_size  :  integer; 
begin 

inputjnessage (  message_type,  integration_step,  mes3age_size  ); 

lowliest  1; 
highjlast  num_points; 


index_table{l] 

s- 

0.0; 

index_table [2] 

2. 

0E3  ; 

indeXjtable[3J 

3.7E3; 

index stable [ 4 ] 

4. 

0E3; 

index_table [ 5 ] 

S" 

6 . 0E3 ; 

index_table[6] 

8. 

0E3; 

index_table(7] 

10.0E3; 

index_table  f 8 ] 

12 

.  0E3; 

rhof_table{l] 

2 . 1163E-3 ; 

rhof __table  [2] 

2 . Q696E-3 

rhof_tablet3] 

*■ 

1.9846E-3; 

rhof stable [4 ] 

1.9696E-3 

rhof_table [5] 

1.8673E-3; 

rhof_table [6] 

:  ” 

1.7684E-3 

rhof __table  [7] 

:• 

1 . 6751E-3 ; 

rhof_table [8] 

1.58SE-3? 
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for  count  2  to  nura_points  do 

diff_table(count]  s-  (rhof_t able {count]  -  rhof_table { count-1 ] )  / 

( index_table [ count ]  -  index_table [ count-1 ] ) ; 

end;  {  Procedure  Initialize_table  } 


Procedure  pivot (  var  ihigh,  ilow  :  integer;  searchvalue  :  real  ); 

var 

ipiv  :  integer; 

begin 

while  ({ihigh  -  ilow)  >  1)  do  begin 
ipiv  < ihigh  +  ilow)  div  2; 

if  search_value  -  index_table [ipiv]  then  begin 
ilow  ipiv; 

ihigh  ilow  +1; 

end 

else  if  search_value  <  index__table [ipiv]  then 
ihigh  ipiv 

else 

ilow  ipiv; 

end; 

end;  {  Procedure  pivot  ) 


Function  search_table {  search_value  :  real  )  :  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table [ilow] )  and 

(search_value  <  index_table [ihigh] )  then  begin 
pivot (  ihigh,  ilow,  search_value  ) ; 


end 

else  if  search_value  -  index_table [ilow]  then  begin 
ihigh  ilow  +  1; 

end 

else  if  search_value  -  index_table[ ihigh]  then  begin 
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ilow  s-  ihigh; 
ihigh  ilow  +  1; 

end 

else  if  3earch_value  <  index_table [1]  then  begin 
ihigh  2; 

ilow  1; 

end 

else  if  search_value  >  index_table [num_points]  then  begin 
ihigh  nura_points; 

ilow  i-  ihigh  -  1; 

end 

else  if  search_value  >  index^table [ihigh]  then  begin 
ihigh  num_points; 

pivot {  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  <  index_t able [ilow]  then  begin 
ilow  s-  1; 

pivot (  ihigh,  ilow,  search_value  ); 

end; 

low_last  :•*  ilow; 

high_last  ihigh; 

search_table  ihigh; 
end;  {  Function  search_table  > 


Procedure  Evaluate_table {  time  :  real  ); 

{ 

Table  RHOF  -  Sloe*  10 

> 

var 

sub_index, 

index  ;  integer: 

z, 

zprime, 

rhof  ;  real; 

begin 

Receive_Real_32bit (  z  ); 

zprime  z  +  zO; 

index  search_table <  zprime  ); 

sub_index  index  -  1; 

rhof  rhof_table(sub_index]  + 

(diff_table [index]  * 

(zprime  -  index_table [ sub_index ])); 
Send_Real_32bit (  rhof  ); 

end; ,  {  Procedure  Evaluate_table  } 
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File:  BLOCK11.PAS 

Module  Problem_Specifications; 

Public  Problera_Specifications; 

Procedure  InitializeJTable; 

Procedure  Evaluate_Table{  time  :  Real  ); 

Public  Solve_Table; 

Var  time,  integration_3tep  :  Real: 

$Include  (’ :PFP : include /tar get. pa s’ ) 

Private  Problera_specifications; 

const 

num_points  -  13; 
asound  -  1117.4; 

var 

low_last, 

high_last  :  integer; 
inv_a sound  :  real; 

acnaf_table  :  array  [1. .nura_points]  of  real; 
index_table  :  array  [1.  .nura_j>oints]  of  real; 
diff_table  :  array  [1 . .numjpoints]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

raessage_type,  message__size  :  integer; 
begin 

input ^message (  message_type,  integration_step,  message_size 

inv_a sound  1.0  /  asound; 
low_la3t  :«  1; 
high_last  num_points; 


index_table[l] 

0.0; 

index_ 

table (2 1 

0.235 

index_table(31 

0.5; 

index 

_table  [4  ] 

0.609 

index_table ( 5 1 

0.777; 

index_ 

_table  [6] 

1.005 

index_table{7] 

1.119; 

index 

_table  [8] 

1.235 

index_table ( 9 ] 

1.41; 

index_ 

_table  [  10  ] 

1.772 

index_table [11] 

2.025; 

index 

_table (121 

2.494 

index_table [131 

2.56; 
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acnaf_table [ 1 ] 

s- 

27.852; 

acnaf_table [2] 

s- 

30.228 

acnaf_table[3] 

31.926; 

acnaf__table  [4] 

*- 

31.728 

acnaf_table[5] 

29.238; 

acnaf_ table [6] 

*■ 

26.304 

acnaf_table[7] 

28.206; 

acnaf_table [8] 

29.028 

acnaf_table[9] 

s- 

27.672; 

acnaf_table [10] 

25.29; 

acnaf_table [11] 

24.078; 

acnaf_table [12] 

22.608 

acnaf_table [13J 

22.488; 

for  count  2 

to  nura_j>oint3 

do 

diff_table [count ]  (acnaf_table [count]  -  acnaf_table [count-1] )  / 
(index_table [count]  -  index^table [count-1] ) ; 

end;  {  Procedure  Initialize^ table  ) 


Procedure  pivot (  var  ihigh,  ilow  ;  integer;  searchj/alue  :  real  ); 

var 

ipiv  :  integer; 

begin 

while  ((ihigh  -  ilow)  >  1)  do  begin 
ipiv  (ihigh  +  ilow)  div  2: 
if  search_yalue  -  index_t able [ipiv]  then  begin 
ilow  ipiv; 
ihigh  ilow  +  1; 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  ipiv 
else 

ilow  ipiv; 

end; 

end;  {  Procedure  pivot  } 


Function  search_table(  search_value  :  real  )  ;  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table [ilow] )  and 


(search_value  <  index_table f ihigh J )  then  begin 
pivot (  ihigh,  ilow,  search_value  ) ; 

and 

else  if  search__value  -  index_t able  [ilow]  then  begin 
ihigh  ilow  +  1; 

end 

else  if  search_yalue  -  index_table [ihigh]  then  begin 
ilow  ihigh; 

ihigh  ilow  +  1; 

end 

else  if  search_value  <  index_table[l]  then  begin 
ihigh  s-  2; 
ilow  1; 

end 

else  if  search_value  >  index_table [num_points]  then  begin 
ihigh  num_points; 

ilow  ihigh  -  1; 

end 

else  if  search_value  >  index_table [ihigh]  then  begin 
ihigh  num_points; 

pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  <  index_table [ilow]  then  begin 
ilow  1; 

pivot <  ihigh,  ilow,  search^value  ); 

end; 

low_last  ilow; 

high_last  ihigh; 

sea rch_t able  s-  ihigh; 
end;  {  Function  search_table  } 


Procedure  Eva lua testable (  time  :  real  ) ; 

Table  ACNAF  -  Bloc*  11 

} 

var 

sub_index, 

index  s  integer; 

reach, 

us, 

acnaf  :  real; 

begin 

Receive_Real_32bit {  us  ); 
mach  us  *  inv_a sound; 
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index  search_table (  mach  ); 

sub_index  index  -  1; 
acnaf  acnaf_table tsub^index]  + 

(diff_table[ index]  * 

(mach  -  index_table(sub_indexj ) ) ; 
Send_Real_32bit (  acnaf  ) ; 

end; .  {  Procedure  Evaluate_table  > 
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File:  BL0CK12.PAS 

Module  Problein_S pacifications; 

Public  Problem_Specifications; 

Procedure  Initiali2e_Table; 

Procedure  Evaluate_Table (  time  s  Real  ); 

Public  SolveJTable; 

Var  time.  integration_step  :  Real; 

SInclude  ( ’ :PFP: include /target . pas r) 

Private  Problem__Specifications; 

const 

num_points  -  13; 
aaound  -  1117.4; 

var 

low_last, 

high_last  :  integer; 
inv_a sound  :  real; 

eldtf_table  :  array  [1 . .nura_points]  of  real; 
index_table  :  array  [1 . .nura^pointsj  of  real; 
diff_table  :  array  [1. .nura_points]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

mes3age_type,  me3sage_3ize  :  integer; 
begin 

input_message  (  raessage__type,  integration_step,  me3sage_size  ); 

inv_a sound  1.0  /  asound; 
low_last  1; 
high_last  :«  num_points; 

index_table { 1 ]  Q.0;  index_table [2]  0.235; 

index_table [3]  0.5;  index_table [4 ]  0.609; 

index  table(5]  0.777;  index_table [ 6]  1.005; 

index_table [7]  1.119;  index_table(8]  1.235; 

index_table(9]  1.41;  index_table [10]  1.772; 

index_table [11]  2.025;  index_table [ 12]  2.494; 

index_table(13]  2.56; 
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cldtf_table [ 1 ] 

4.103; 

cldtf_table [2] 

3.764; 

cldtf_table[3] 

3.337; 

cldt ratable [4] 

:«  3.2571 

cldtf_table [ 5 ] 

s-  3.134; 

cldt f_t able { 6] 

3.228; 

cldt f_table [ 7 ] 

3.3162; 

cldt f_t able [8] 

3.4058 

cldtf_table [9] 

3.198; 

cldtf_table  [10] 

2.44; 

cldt f_t able [11] 

2.02; 

cldtf_table [12] 

1.4135, 

cldtf_table [13] 

i-  1.337; 

for  count  2 

to  nura__points  do 

diff_table {count]  (cldtf_table [count ]  -  cldtf_table [count-1] )  / 
(index— table [count]  -  index_table [ count- 1] ) ; 

end;  {  Procedure  Initiali2e_table  } 


Procedure  pivot (  var  ihigh,  ilow  ;  integer;  search_value  :  real  ); 

var 

ipiv  :  integer; 

begin 

while  {(ihigh  -  ilow)  >  1)  do  begin 
ipiv  (ihigh  +  ilow)  div  2; 

if  aearch^value  -  index_t able  [ipiv]  then  begin 
ilow  ipiv; 

ihigh  ilow  +1;  * 

end 

else  if  search_value  <  index_table [ipiv]  then 
ihigh  ipiv 
else 

ilow  ipiv; 

end; 

end;  {  Procedure  pivot  > 


Function  search_table (  search_value  ;  real  )  :  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search_value  >  index_table [ilow] )  and 
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( search_value  <  indexj table  [ihigh] )  then  begin 
pivot (  ihigh,  ilow,  search_value  ) ; 

end 

else  if  search_value  -  index_table[ilow]  then  begin 
ihigh  i-  ilow  +  1; 

end 

else  if  search_value  -  index_table [ihigh]  then  begin 
ilow  ihigh; 
ihigh  ilow  +1; 

end 

else  if  seareh_value  <  index_table [ 1 ]  then  begin 
ihigh  2; 

ilow  s-  1; 

end 

else  if  sear ch^value  >  index_table [num_points]  then  begin 
ihigh  num_points; 

ilow  ihigh  -  1; 

end 

else  if  search_value  >  index— table [ihigh]  then  begin 
ihigh  num_points; 

pivot (  ihigh,  ilow,  search_value  ); 

end 

else  if  search_value  <  index_t able [ilow]  then  begin 
ilow  1; 

pivot (  ihigh,  ilow,  search_value  ); 

end; 

lowJLast  ilow; 

high_last  ihigh; 

search^table  ihigh; 
end;  {  Function  search_table  } 


Procedure  Evaluate^table (  time  :  real  ); 

( 

Table  CLDTF  -  Block  12 

} 

var 

sub_index, 

index  :  integer; 

mach, 

us, 

cldtf  :  real; 

begin 

Receive_Real_32bit {  us  ) ; 
mach  us  *  inv  asound; 
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index  search_table {  mach  ); 

aub_index  index  -  1; 
cldtf  cldtf_table{sub_index]  + 

<diff_table[ index]  * 

(roach  -  index_table [sub_index] ) ) ; 
Send_Real_32bit (  cldtf  ); 

end; .  {  Procedure  Evaluate_table  ) 
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File:  BLOCK13.PAS 

Module  Problem_Specifications; 

Public  Problem__Specificati de¬ 
procedure  Initialize_Table; 

Procedure  Evaluate_Table {  time  :  Real  ); 


Public  SolveJTable; 

Var  time,  integration_step  :  Real; 

$Include  (' :PFP: include /target . pas') 
Private  Problera_specifications: 


const 

num_point3  -  13; 
asound  -  1117.4; 


low_laat, 

high_last 

inv_asound 


integer; 

real; 


clpf_table 
index_table 
diff  table 


array  (1 . ,num_points]  of  real; 
array  [1 . ,num_points]  of  real; 
array  [1 . .nura_points]  of  real; 


Procedure  Initialize_table; 

var 

count  :  integer; 

message_type,  message_size  ;  integer; 

begin 

input  message (  message_type,  integration_step,  message_size  ) 

inv_asound  : —  1.0  /  asound; 

low_last  s-  1: 

high  last  num_points; 


index_table [1] 

0.0: 

index_table (2] 

0.235 

index^t able { 3 ] 

0 .  S; 

index_table[4] 

0.609 

index_table[5] 

0.777; 

index_table [6] 

1.005 

index_table[7] 

1.119; 

index_table [ 8 ] 

1.235 

index_table [9] 

1.41; 

index_table [10] 

1.772 

index_table ( 11  ] 

index  table [13] 

2.025; 

2.56; 

index_table [ 12] 

2.494 
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clpf_table[l] 

s- 

8.716; 

clpf_table[2] 

■  ** 

8.7254; 

clpf_table[3] 

8.726; 

clpf_table[4] 

8.7476; 

clpf_table  [5] 

8.781; 

clpf_table[6] 

8“ 

11.335; 

clpf__table(7] 

10.4; 

clpf_table [8] 

9.5532; 

clpf_table  [9] 

8.2825; 

clpf__table  [10] 

8.042; 

clpf_ table (11] 

7.826; 

clpf_table { 12 ] 

7.5253; 

clpf_table [13] 

!  — 

7.483; 

for  count  2 

to 

nura_points  do 

dif f_table {count]  (clpf_table [count ]  -  clpf_table [count-1 ])  / 

(index_table[ count]  -  index_table [count-1] ) ; 

end;  {  Procedure  Initialize_table  ] 


Procedure  pivot (  var  ihigh,  ilow  :  integer;  search_value  :  real  ); 

var 

ipiv  s  integer; 

begin 

while  ((ihigh  -  ilow)  >1)  do  begin 
ipiv  s-  (ihigh  +  ilow)  div  2; 
if  search_value  -  index_table[ipiv]  then  begin 
ilow  ipiv; 
ihigh  :*»  ilow  +  1; 

end 

else  if  search_value  <  index__table  [ipiv]  then 
ihigh  ipiv 
else 

ilow  ipiv; 

end; 

end;  {  Procedure  pivot  } 


Function  search_table (  search__value  :  real  )  ;  integer; 

var 

ihigh, 

ilow  :  integer; 

begin 

ilow  low_last; 
ihigh  high_last; 

if  (search__value  >  index_table  [ilow] )  and 
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(searchjralue  <  index_table [ihigh] )  then  begin 
pivot (  ihigh,  ilow,  search_value  ); 


end 

else  if  search_value  -  index_table [ilow]  then  begin 
ihigh  ilov  +  1; 

end 

else  if  search__value  -  index_table [ihigh]  then  begin 
ilow  ihigh; 

ihigh  ilow  +1; 

end 

else  if  search_yalue  <  index_table[l]  then  begin 
ihigh  2; 

ilow  1; 

end 

else  if  search_value  >  index_table[num_points]  then  begin 
ihigh  :»  numjpoints; 
ilow  ihigh  -  If 

end 

else  if  search_value  >  index_table[ ihigh]  then  begin 
ihigh  nura_points; 

pivot (  ihigh,  ilow,  search_value  >; 

end 

else  if  search_value  <  index_t able [ilow]  then  begin 
ilow  1; 

pivot (  ihigh,  ilow,  search^value  ); 

end; 

low_last  ilow; 

high_last  ihigh; 

search^table  ihigh; 
end;  {  Function  search_table  } 


Procedure  Evaluate_table (  time  :  real  ) ; 
{ 

Table  CLPF  -  Bloc*  13 

) 

var 

sub_index, 

index  :  integer; 

mach, 

us, 

clpf  :  real; 

begin 

Receive__Real_32bit  (  us  ); 
mach  us  *  inv  a sound; 
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index  search_table (  mach  ); 

sub^index  :*  index  -  1; 

cipf  clpf__table[sub_index]  + 

(diff_t able {index]  * 

(mach  -  index_table [sub_index] ) ) ; 
Send_Real_32bit (  cipf  ) ? 


end; .  {  Procedure  Evaluato_table  } 
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File:  BLOCK14 .PAS 

Module  Problem_Specifications; 

Public  Problera_Specifications; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real 

first  eval  :  boolean  ); 


Public  Solve_Differential_Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$ Include  (' :PFP: include /tar get. pa s’) 

Private  Problera_Specifications; 


const 

asound  -  1117.4; 
g  -  32.17; 

usO  -  15.33; 
thetaO  -  0.942; 


rm,  t,  acdO,  rho, 

rs,  wns,  theta,  vs, 

qs,  ws,  us, 

thetpr,  sinth,  costh, 

wx,  rsvs,  qsws,  uswx, 

uswxsq,  vl3,  vl4, 

uforce,  vl6,  usdot  :  real; 


Procedure  Initial_Conditions; 


var 


message_type,  raessage_size  :  integer; 

begin 

input ^message (  message_type,  h,  message_size  ); 

Y  usO; 
time  0.0; 


end; 


Procedure  Evaluate  Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 
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first  eval 


{ 

Basic  Integrator  -  State  us  -  Block  14 

> 

begin 


boolean  ) ; 


us  Y; 

Send__Real_32bit  (us); 

Receive_Real_32bit (  vs  ); 

R«ceive_Real_32bit (  theta  ) ; 

Reeeive_Real_32bit (  r s  )  ; 

Receive_Real_32bit (qs); 

Receive_Real_32bit (  t  ) ; 

Receive_Real_32bit (  ws  ); 

Receive_Real_32bit (  rho  ) ; 

Receive_Real_32bit (  acdO  ) ; 

Receive_Real_32bit (  wns  ); 

Receive_Real_32bit (  rra  ) ; 

( 

if  first_eval  then  Output_Message(  Real_32bit,  us  /  asound,  1  ); 

) 

thetpr  theta  +  thetaO; 
sinth  sin(  thetpr  ); 
costh  cos (  thetpr  ); 
wx  wns  *  costh; 
rsvs  rs  *  vs; 

qsws  qs  *  vs; 

uswx  us  +  wx; 

uswxsq  uswx  *  uswx; 
vl3  rho  *  uswxsq; 

Vl4  acdO  *  vl3; 

uforce  !-  t  -  0.5  *  vl4; 
vl6  rra  *  uforce; 


usdot  vl6  -  g  *  sinth  +  rsvs  -  qsws; 
Y_dot  usdot; 


end; 


File:  BL0CK15 .PAS 

Module  Problera_Specifications; 

Public  Problem^ Specifications; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  ¥,  time  :  Real; 

first_eval  :  boolean  ) ; 

Public  Solve_Differential_Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$lnclude  ( ' : PFP : include /target .pas’) 

Private  Problem_Specifications; 

const 

vsO  -  0.0; 

var 

fy,  phi,  f z,  rm, 
acna,  rho,  us,  wwe, 
rs,  vs, 

sinphi,  cosphi,  wy, 

rsus,  vsvy,  rhous, 

vl9,  v20,  fty, 

vforce,  v22,  vsdot  :  real; 

Procedure  Initial_Conditions; 

var 

message_type,  message_size  :  integer; 
begin 

input_message (  message_type,  h,  message^size  ); 

Y  vsO; 
time  0.0; 

end; 


Procedure  EvaluateJDerivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

f irst_eval  :  boolean  ) ; 
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) 

begin 

vs  Y; 

Receive_Real_32bit {  us  ); 
Send_Real_32bit {  vs  ) ; 
Send_Real_32bit (  vs  ) ; 
Receive_Real_32bit (  rs  ); 
Receive_Real_32bit (  phi  ); 
Receive_Real_32bit (  wwe  ) ; 
Receive_Real__32bit  (  rho  ); 
Receive_Real_32bit (  fz  ); 
Receive_Real_32bit {  fy  ); 
Receive_Real_32bit {  acna  ) ; 
Receive_Real_32bit {  rra  ) ; 

sinphi  sin (  phi  ); 

cosphi  co 3 (  phi  ); 

wy  wwe; 

rsus  rs  *  us; 

vswy  vs  -  wy; 

rhous  j-  rho  *  us; 

vl9  ;«■*  acna  *  rhous; 

v20  :*•  vl9  *  vswy; 

fty  fy  *  cosphi  +  fz  *  sinphi; 

vforce  fty  -  0.5  *  v20; 

v22  vforce  *  rift; 

vsdot  v2 2  -  rsus; 

Y  dot  vsdot; 


end; . 
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File;  BLOCK16.PAS 

Module  Problera_Specifications; 

Public  Problera_Specif icationa  .* 

Procedure  Initial^ Conditions; 

Procedure  Evaluate_Derivatives {  var  Y_dot  :  Real;  Y,  time  :  Real 

first  eval  :  boolean  ) ; 


Public  Solve_Differential_ Equation ; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first— eval  ;  boolean; 

$lnclude  { ♦ ;PFP: include/target. pas’) 

Private  Problera_Specifications: 

const 

g  -  32.17; 

wsO  -  0.0; 
thetaO  -  0.942; 


qs,  us,  theta,  rm, 

fz.  phi,  fy,  vns, 

acna,  rho,  ws, 

thetpr,  sinth,  costh, 

sinphi,  cosphi,  wz, 

qsus,  rhous,  vl9,  ftz, 

wswz,  v24,  wforce, 

v26,  wsdot  :  real; 


Procedure  Initial_Conditions; 


var 


mes3age_type,  message^ size  :  integer; 

begin 

inputjnessage (  message_type,  h,  raessage_size  ); 

Y  wsO; 
time  0.0; 


end; 


Procedure  £valuate_Derivatives (  var  Y_dot  ;  Real;  Y,  time  :  Real; 
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( 

Basic  Integrator 

} 

begin 


first_eval 

State  ws  -  Block  16 


boolean  ) ; 


ws  Y; 

Receive_Real_32bit {  us  ); 
Receive_Real_32bit <  theta  ); 
Receive^ Real_32bit  <  qs  ); 
Receive_Real_32bit (  phi  ) ; 
Send_Real_32bit (  ws  ) j 
Receive__Real_32bit  (  rho  )  ; 
Receive_RealJ32bit (  f z  ) ; 
Receive_Real_32bit {  fy  ); 
Receive_Real_32bit {  wns  ) ; 
Receive_Real_32bit (  acna  > ; 
Receive_Real_32bit (  rra  ); 


thetpr  theta  +  thetaO; 

sinth  sin(  thetpr  ); 

costh  cos(  thetpr  ); 

sinphi  sin(  phi  ); 

cosphi  cos (  phi  ); 

wz  wns  *  sinth; 

qsus  qs  *  us; 

rhous  ;•  rho  *  us; 

vl9  acna  *  rhous; 

wswz  ws  4*  wz; 

v24  wswz  *  vl9; 

ftz  fz  *  cosphi  -  fy  *  sinphi; 

Wforce  -ftz  -  0.5  *  v24; 

v26  rra  *  wforce; 

wsdot  qsus  +■  g  *  costh  +  v26; 

Y  dot  wsdot; 


end; . 
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File:  BL0CK17.PAS 

Module  Problem_Specifications; 

Public  Problera_Specifications; 

Procedure  Initial_Conditions; 

Procedure  EvaluateJJerivatives (  var  Y_dot  :  Real;  Y,  time  ;  Real; 

first_eval  :  boolean  ) ; 

public  Solve_Differential_Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$ Include  (• :PFP:include/target.pas') 

Private  Problem_Specifications; 

const 


psO 

- 

o 

o 

ix 

- 

25.77; 

dx 

- 

-2.0; 

a 

- 

2.64; 

d 

- 

1.833; 

dt 

• 

0.05236, 

var 

rho,  clp,  us, 
cldt.  It,  ps, 
p7,  p8,  plO,  pll, 
rhous,  psclp, 
uscldt,  v29, 

v30 ,  psdot  :  real; 

Procedure  Initial_Conditions; 

var 

raessage_type,  message_size  :  integer; 
begin 

input_message (  message_type,  h,  message_size  ); 

p7  1.0  /  ix; 

p8  dx  /  ix; 

plO  a  *  d  *  d  *  0.25; 

pll  a  *  d  *  dt  *  0.5; 

Y  :•  psO; 
time  0.0; 
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end; 


Procedure  Evaluate_Derivatives (  var  Y_dot  ;  Real;  Y,  time  :  Real; 

first_eval  ;  boolean  ); 

{ 

Basic  Integrator  -  State  ps  -  Block  17 

} 

begin 


ps  Y; 

Receive_Real_32bit (  us  ) ; 

Send_Real_32bit (  ps  ) ; 

Receive_Real_32bit (  It  ); 

Receive_Real_32bit (  rho  ) ; 

Receive_Real_32bit (  clp  ) ; 

Recaive_Rea  1_J32 bit  {  cldt  ) ; 

{ 

if  first_eval  then  Out put_Me3 sage {  Real_32bit,  ps.  1  ); 
} 

rhous  rho  *  us; 

psclp  ps  *  clp; 

uscldt  us  *  cldt; 

v29  -plO  *  psclp  +  pll  *  uscldt; 

v30  rhous  *  v29; 

psdot  p7  *  v30  +  p7  *  It  +  p8  *  ps; 

Y_dot  psdot; 


end; 
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File  BLOCK18.PAS 

Module  Problem_Specifications; 

Public  Problem_Specifications; 

Procedure  lnitial_Conditions; 

Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real 

first  eval  :  boolean  ) ; 


Public  Solve_Dif ferential_Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$ Include  ( ' : PFP : include/ target . pas  * ) 

Private  Problera_Specifications; 

const 

phiO  -  0.0; 
thetaO  -  0.942; 


ps,  theta,  rs, 
phi, 

thetpr,  sinth,  costh, 
rcos,  phidot  :  real; 


Procedure  Initial_Conditions: 

var 

mes3age_type,  message_size :  integer; 

begin 

input  message(  message_type,  h,  message_size  ); 

Y  phiO; 
time  : -  0.0; 

end; 


Procedure  Evaluate_Derivatives (  var  Y_dot  s  Real;  Y,  time  ;  Real; 

first  eval  ;  boolean  ) ; 


{ 

Basic  Integrator  -  State  phi  -  Block  18 


) 

begin 
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phi  Y; 

Receive_Real_32bit (  ps  ) ; 
Receive_Real_32bit {  theta  ) ; 
Receive_Real_32bit (  rs  ); 
Send_Real _32bit {  phi  ) ? 


if  first_eval  then  Output_Message (  Real_32bit,  phi,  1  ); 
} 

thetpr  theta  +  thetaO; 

sinth  sin<  thetpr  ); 

costh  cos(  thetpr  ); 

rcos  1.0  /  costh; 

phidot  ps  +  rcos  *  sinth  *  rs; 

Y_dot  phidot; 


end; . 
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File:  BLOCK 19. PAS 

Module  Problera_Specifi cat ions; 

Public  Problera_Specifications; 

Procedure  Initial_Conditiona; 

Procedure  EvaluateJJerivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first_eval  :  boolean  ) ; 

Public  Solve_Differential_£quation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$ Include  { * :PFP : include/target . pas ' ) 

Private  problem_Specifications; 

const 

zO  -  3990.0; 

zic  -  0.0;  c 

thetaO  -  0*.  942; 


var 

us,  theta,  vs, 
z, 

thetpr,  sinth,  costh, 

2dot  :  real; 


Procedure  Initial_Conditions; 

var 

raessage_type*  raessage_size  :  integer; 

begin 

input_raessage (  message_type,  h,  message_size  ); 


Y  zic; 
time  0.0; 

end; 


Procedure  EvaluateJDerivatives <  var  Y_dot  :  Real;  Y,  time  :  Real; 

first  eval  :  boolean  ) ; 


( 


Basic  Integrator  -  State  z  -  Block  19 
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begin 

Z  Y; 

Receive_Real_32bit (  us  ) ; 

Send_Real _32bit (  z  ); 

Receive_Real_32bit (  theta  ) ; 
Receive_Real_32bit (  ws  ) ; 

{ 

if  first_eval  then  Output_Message (  Real_32bit,  z 

} 

thetpr  theta  +  thetaO; 
sinth  s-  sin(  thetpr  ); 
costh  s-  coa(  thetpr  ); 
zdot  us  *  sinth  -  vs  *  costh; 

Y  dot  zdot; 


+  zO,  1  >; 


end; . 
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File:  BLOCK20.PAS 

Module  Problem_Specif ications; 

Public  Problem_Specif ications ; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivatives {  var  Y_dot  :  Real;  Y,  time  j  Real; 

first_eval  :  boolean  ) ; 

Public  Solve_Differential__Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean? 

$ Include  < ’ : PFP : include/ target . pas ' ) 

Private  Problera_Specif ications; 

const 

0.0; 

0.873; 

0.914; 

28. 6S; 

0.246; 

1.875E-3; 

phi,  psi, 

p22,  p23,  p30, 
sinphi,  cosphi, 
garamat,  gtl, 

gt2dot  :  real; 

Procedure  Initial_Conditions; 

var 

raessage_type,  raessage_size  :  integer; 
begin 

input_message (  message^ type,  h,  raessage_size  ); 

p22  :«  si  *  gain; 
p23  s2  *  gain; 
p30  1.0  /  tau2; 

Y  gt20 ; 
time  0.0; 


gt20 

tl 

si 

gain 

s2 

tau2 


theta, 

gt2. 


end; 
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Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time 

first_eval  :  boolean  ); 

Basic  Integrator  -  State  gt2  -  Block  20 

} 

begin 

gt2  Y; 

Send_Real_32bit (  gt2  ) ; 

Receive_Real_32bit (  theta  ) ; 

Receive_Real_32bit (  psi  ); 

Receive_Real_32bit (  phi  ) ; 

sinphi  sin(  phi  ); 

cosphi  cos (  phi  ); 

garamat  theta  *  cosphi  +  psi  *  sinphi; 

if  time  <  tl  then 

gtl  garemat  *  p22 

else 

gtl  :*•  gainmat  *  p23; 
gt2dot  s-  p30  *  (  gtl  -  gt2  ); 

Y_dot  gt2dot; 


:  Real; 


end; . 
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File:  BLOCK21.PAS 

Module  P roblem__Speci  f ica t ions ; 

Public  Problem_Speci f ica t ions; 

Procedure  lnitial_conditions; 

Procedure  EvaluateJJerivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first  eval  :  boolean  ) ; 


Public  Solve_Oifferential_Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$lnclude  (• :PFP : include/target .pas ' ) 

Private  Problera_Specifications; 

const 

gp20  -  0-0; 
tl  -  0.873; 
si  -  0.914; 
gain  -  28.65; 
s2  -  0.246; 
tau2  -  1.875B-3; 

var 

theta,  phi,  psi, 

gpz, 

p22,  p23,  p30, 
sinphi,  cosphi, 
garamap,  gpl, 

gp2dot  :  real; 


Procedure  Initial^Conditions; 

var 

message_type,  message_size  :  integer; 
begin 

input_message (  message_type,  h,  message_size  ); 

p22  si  *  gain; 

p23  s2  *  gain; 

p30  1.0  /  tau2; 

Y  gp20; 
time  0.0; 


end; 
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Procedure  Evaluate_Derivatives (  var  Y__dot  :  Real;  Y,  time  ;  Real; 

first_eval  :  boolean  ) ; 

Basic  Integrator  -  State  gp 2  -  Block  21 

} 

begin 

gp2  Y; 

Send_Real_32bit {  gp2  ); 

Receive_Real_32bit {  theta  ) ; 

Receive_Real_32bit (  psi  ) ; 

Reeeive_Real_32bit {  phi  ); 

sinphi  sin(  phi  ); 

cosphi  cos(  phi  ); 

gammap  psi  *  cosphi  -  theta  *  sinphi; 
if  time  <  tl  then 

gpl  gammap  *  p22 

else 

gpl  gammap  *  p23; 

gp2dot  p30  *  (  gpl  -  gp2  ); 

Y_dot  gp2dot ; 

end; . 
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File:  BLOCK22.PAS 

Module  Problem_Specifications; 

Public  Problem^Specifications; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivatives  (  var  Y__dot  :  Real;  Y,  time  :  Real 

first  eval  :  boolean  ); 


Public  Solve J3ifferential_Equat ion; 

var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

Sinclude  :PFP: include/target. pas’ ) 

Private  Problem_Specifications; 

const 

gt40  -  0.0; 
tl  -  0.873; 
gain  -  28.65; 
si  -  0.914; 
s2  -  0.246; 
taul  -  17.34E-3; 
tau2  -  1.875E-3; 
tau3  -  670.0E-6; 


theta,  phi,  psi, 

gt2,  gt4, 

p22,  p23,  p27, 

p28,  p29, 

sinphi,  cosphi, 

garranat,  gti,  gt3, 

gt4dot  :  real; 


Procedure  Initial_Conditions; 

var 

message_type,  message_size  :  integer; 
begin 

input^messagef  message_type,  h,  mes3age_size  ); 

p22  si  *  gain; 

p23  s2  *  gain; 

p27  taul  /  tau2; 

p28  1.0  -  p27; 
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p29  :«  1.0  /  tau3; 
Y  gt40; 
time  0.0; 


end; 


Procedure  Evaluate_Derivatives <  var  Y_dot  :  Real;  Y,  time 

first_eval  :  boolean  ) ; 


{ 


Basic  Integrator  -  State  gt4  -  Block  22 

} 

begin 


Real 


gt4  Y; 

Receive_Real_32bit {  gt2  ) ; 
Send_Real_32bit <  gt4  ); 
Receive_Real_32bit (  theta  ) ; 
Receive_Real_32bit (  psi  ); 
Receive_Real_32bit (  phi  ); 

sinphi  :«  sin(  phi  ); 
cosphi  cos (  phi  ); 

gammat  theta  *  cosphi  +  psi  *  sinphi; 
if  time  <  tl  then 

gtl  gammat  *  p22 

else 

gtl  gammat  *  p23; 

gt3  p27  *  gtl  +  p2S  *  gt2; 

gt4dot  p29  *  (  gt3  -  gt4  ) ; 

Y_dot  gt4dot; 


end; . 
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File:  BLOCK23.PAS 

Module  Problera_Specifications; 

Public  Problem_Specifications; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivatives <  var  Y_dot  :  Real;  Y,  time  :  Real; 

.  first_eval  :  boolean  ) ; 

Public  Solve_Differential_Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

^Include  ( * : PFP : include/target .pas*) 

Private  Problem_Speciffications; 

const 

gp40  -  0.0; 

tl  -  0.873;  > 

gain  -  28.65; 

si  -  0.914; 

s2  -  0.246; 

taul  -  17.34E-3; 

tau2  -  1.875E-3; 

tau3  -  670.0E-6; 

var 

theta,  phi,  psi, 

gp2.  gp4, 

p22,  p23,  p27, 

p28,  p29, 

sinphi,  cosphi, 

gararaap,  gpl,  gp3, 

gp4dot  :  real; 

Procedure  Initial_Conditions; 

var 

message_type,  raessage_size  s  integer; 
begin 

input_message {  raessage_type,  h,  message_3ize  ); 

p22  si  *  gain; 

p23  s2  *  gain; 

p27  taul  /  tau2; 

p28  s-  1.0  -  p27; 
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p29  1.0  /  tau3; 

Y  gp40; 
time  0.0; 


end; 


Procedure  Evaluate_Derivatives <  var  Y_dot  s  Real?  Y,  time  :  Real; 

fir3t_eval  :  boolean  ) j 


{ 


Basic  Integrator  -  State  gp4  -  Block  23 


) 


begin 


gp4  Y; 

Receive_Real_32bit (  gp2  ); 
Send_Real_32bit (  gp4  ); 
Receive_Real_32bit (  theta  ); 
Receive_Real_32bit (  psi  ) ; 
Receive_Real_32bit (  phi  ) ; 


sinphi  sin {  phi  )? 
cosphi  cos(  phi  ); 

gammap  psi  *  cosphi  -  theta  *  sinphi; 
if  time  <  tl  then 

gpl  gammap  *  p22 

else 


gpl  gammap  *  p23; 
gp3  p27  *  gpl  +  p28  *  gp2; 
gp4dot  p29  *  (  gp3  -  gp4  ); 
Y_dot  gp4dot; 


end; . 
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Files  BLOCK24 .PAS 

Module  ProblemjSpecifications; 

Public  ProblemjSpecifications; 

Procedure  Initial_Conditions; 

Procedure  EvaluateJDerivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first_eval  :  boolean  ) ; 


Public  Solve J)ifferential_Equat ion; 

Var 

intj.imit, 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$Include  <’ : PFP: include /target .pas * ) 

Private  Problera_Speeifications; 

const 


gt50 

“ 

0.0; 

c 

- 

0.5E-6; 

rl 

- 

20.0E3; 

r2 

- 

147. 0E3 

vl 

- 

0.24; 

v2 

- 

0.18; 

eomax 

- 

2.5; 

eimax 

- 

0.S; 

gt4 ,  gt5, 
p3S,  p36, 

rsw_minus,  rsw_plusf 

gt€,  gt5dot  :  real; 

aetff,  resetff, 

gt6hi,  gt61o  :  boolean; 

ly_3rtff , 

oldy  :  array£1..2]  of  boolean; 


Procedure  Initial_Conditions; 

var 

message_type,  message_3i2e  :  integer; 
begin 

input jnes sage {  message_type,  h.  message_size  ); 
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p35  1.0  /  (  rl  *  c  ); 

p36  1.0  /  (  r2  *  c  ); 

Y  gt50; 
int_limit  eimax; 
time  0.0; 


end; 


Function  srtff(  index  :  integer;  first_time  :  boolean  )  :  boolean; 

begin 

if  time  -0.0  then  begin 

ly_srtff [index]  false; 
oldy [index]  s-  false; 

end 

else  if  first_time  then  begin 

if  setff  then  ly_j»rtff  [index]  true; 
if  resetff  then  ly_s rtf f [index]  false; 

if  (not  setff)  and  (not  resetff)  then  ly_srtff [index]  oldytindex] 
if  setff  and  resetff  then  ly_srtff [index]  not  oldytindex]; 
oldytindex]  ly_srtff[ index ] ; 

end; 

srtff  ly_srtff [index] ; 

end;  {  Function  srtff  } 


Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time 

first  eval  :  boolean  ) ; 


Basic  Integrator  -  State  gt5  -  Block  24 


begin 


Real; 


gtS  Y; 

Send_Real_32bit <  gtS  ); 

Receive_Real_32bit (  gt4  ); 

{ 

if  first_eval  then  Output_Message (  Real_32bit,  gtS,  1  ); 
l 

if  gt5  >  vl  then  setff  true  else  setff  false; 
if  gtS  <  -v2  then  resetff  true  else  resetff  false; 
gt6hi  srtff (  1,  first_eval  ); 

if  gt5  <  -vl  then  3etff  :»  true  else  setff  false; 
if  gtS  >  v2  then  resetff  true  else  resetff  false; 
gt61o  srtff {  2,  first_eval  ); 

if  gt6hi  then 
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rawjslus  eoraax 

else 

rsw_plus  s-  0.0; 
if  gt€lo  then 

rsv_minus  eomax 

else 

rsw_minus  :«  0.0; 
gt6  i-  rsw_plus  -  rsw_minus; 
gtSdot  p35  *  gt4  -  p36  *  gt6; 
Y_dot  gtSdot; 
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File:  BLOCK25.PAS 

Module  Problera_Speci fications; 

Public  Problera_Specifications; 

Procedure  Initial^Conditions; 

Procedure  Evaluate_Derivatives {  var  Y_dot  :  Real;  Y,  time 

first  eval  :  boolean  ) ; 


Public  Solve_Differential_Equation; 

Var 

intJLimit, 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$Include  ( • : PFP : include/ target .pas') 

Private  Problera_Specifications; 

const 


gp50 

- 

0.0; 

c 

- 

O.SE-6; 

rl 

- 

2Q.0E3; 

r2 

- 

147.0E3; 

vl 

- 

0.24; 

v2 

- 

0.18; 

eoraax 

- 

2.5; 

eimax 

- 

0.5; 

var 

gp4,  gp5, 
p35,  p36, 

rsw_minus,  rsw_plu3, 

gp6,  gpSdot  :  real; 

setff,  resetff, 

gp6hi,  gp61o  :  boolean; 

ly_srtff, 

oldy  :  array  [1..2]  of  boolean; 


Procedure  lnitial_Conditions; 

var 

raessage_type,  rcessage_size  :  integer; 

begin 

input_message (  raes3age_type,  h,  message_size  ); 


Real; 
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p35  s-  1.0  /  (  rl  *  e  ); 
p36  s-  1.0  t  (  r2  *  c  ): 
Y  gp50; 
int_limit  eiraax; 
time  0.0; 


end; 


Function  srtff (  index  :  integer;  fir3t_tirae  :  boolean  )  :  boolean; 

begin 

if  time  -  0.0  then  begin 

ly_srtff [index]  false; 
oldy [index]  false; 

end 

else  if  first_time  then  begin 

if  setff  then  ly_srtff [index]  true; 

if  resetff  then  ly_srtff [index]  :•  false; 

if  (not  setff)  and  (not  resetff)  then  ly_srtff [index]  oldy [index] 

if  setff  and  resetff  then  ly_s rtf f [index]  not  oldy [index]; 

oldy [index]  ly_srtff [index] ; 

end; 

srtff  ly_srtff [index] ; 

end;  (  Function  srtff  } 


Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first_eval  :  boolean  ) ; 


Basic  Integrator  -  State  gp5  -  Bloch  25 

> 

begin 


gp5  Y; 

Send_Real_32bit {  gp5  ); 

Receive_Real_32bit (  gp4  ) ; 

1 

if  first_eval  then  Output_Message (  RealJ32bit,  gp5,  1  ); 

} 

if  gp5  >  vl  then  setff  true  else  3etff  false; 
if  gp5  <  -v2  then  resetff  true  else  resetff  false; 
gp6hi  3rtff(  1,  first_eval  ); 

if  gp5  <  -vl  then  setff  true  else  setff  :«  false; 
if  gp5  >  v2  then  resetff  true  else  resetff  false; 
gp61o  srtff {  2,  first_eval  ); 

if  gp6hi  then 
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raw_plus  eomax 

else 

r3W_plus  0.0; 

if  gp61o  then 

rsw_rainus  :«  eomax 

else 

rsw_minus  :«■  0.0; 
gp6  rsw_plus  -  rsw_minus; 
gpSdot  p3S  *  gp4  -  p36  *  gp6; 
Y_dot  gp5dot; 


end;  . 
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Files  BLOCK26.PAS 

Module  Problera_Specifications; 

Public  P roblem_Speci f icat ions ; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivative» (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first_eval  :  boolean; 
var  mode  :  boolean  ) ; 


Public  Solve_Differential_Equation; 

Var 

int_limit, 

time,  h,  Y,  Y_dot  :  real; 
first_eval,  mode  :  boolean; 

$ Include  < ’ : PFP : include/target . pas • ) 

Private  Problera_Specif icat ions; 

const 

fzic  -  0.0; 
trf  -  4.0E-3; 
eomax  •  2.5; 
vl  -  0.24; 
v2  -  0.18; 
tdel  -  8.0E-3; 
fside  -  380.0; 

var 

gt5,  fz, 

half_eomax,  p43, 
gt7, 

gt6,  rsvjplus, 
rsw_rainus, 
switch_up, 
switch_dovn, 
fzdot 

delay_head, 
delay__tail, 
delay_index 
gt6hi,  gt61o, 
setff,  resetff, 
fzpos,  gt7hi, 
gt7lo,  tdtO, 
tutO,  tup,  tdown 

ly__srtff , 

oldy  :  array  [1..4]  of  boolean; 

ly_dlyff, 

oldx  :  array  [1..2]  of  boolean; 


:  real; 


:  integer; 


:  boolean; 
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delay_gt6  :  array  [0..99]  of  real; 

Procedure  Initial_Condition3; 

var 

count  :  integer; 

message_type,  message_3ize  :  integer; 
begin 

inputjnessage (  message_type,  h,  message_size  ); 

half_eomax  eoraax  /  2.0; 

p43  fside  /  trf; 

Y  fzic; 
intJLimit  fside; 
delay_index  trunc(tdel/h)  *  4; 
for  count  ;•  0  to  <delay_index  -  1)  do 
delay_gt6[count]  0.0; 
time  0.0; 

delay^head  0; 

delay_tail  delay_index  -  1; 


end; 


Function  srtff (  index  t  integer;  first_time  :  boolean  )  :  boolean; 
begin 

if  time  -  0.0  then  begin 

ly_srtff (index]  false; 
oldyt index]  false; 

end 

else  if  fir3t_time  then  begin 

if  setff  then  lyjartff  [index]  true; 
if  resetff  then  ly_srtff [index]  :*  false; 

if  (not  setff)  and  (not  resetff)  then  ly_srtff [ index  1  oldy[index]; 
if  setff  and  resetff  then  ly_srtff [index]  not  oldy [index]; 
oldy[index]  ly_srtff [index] ; 

end; 

srtff  ly_srtff [index] ; 

end;  (  Function  srtff  } 


Function  dlyff(  first_time,  value  :  boolean;  index  ;  integer  )  :  boolean; 


begin 
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if  time  *  0.0  then  begin 

ly_dlyff [index]  :*•  false? 
oldx[ index]  value 

end 

else  if  first_tirae  then  begin 

ly_dlyff [index]  oldx[ index ] ; 

oldx[ index]  value 

end; 

dlyff  ly_dlyff [index] ; 

end;  (  Function  dlyff  ] 


Procedure  Evaluate_Derivatives (  var  Y_dot  ;  Real;  Y»  time  :  Real; 

first_eval  ;  boolean; 
var  mode  :  boolean  ) ; 

< 

Basic  integrator  -  State  fz  -  Block  26 

) 

var 

count, 

kount  :  integer; 

begin 

fz  Y; 

Receive_Real_32bit (  gt5  ) ; 

Send_Real_32bit (  f z  ) ? 

{ 

if  first_eval  then  Out put_Mes sage (  Real_32bit,  fz,  1  )? 

) 

if  gt5  >  vl  then  setff  true  else  setff  false; 
if  gt5  <  -v2  then  resetff  true  else  resetff  false; 
gt6hi  srtff<  1.  first_eval  ); 

if  gtS  <  -vl  then  setff  true  else  setff  false; 
if  gt5  >  v2  then  resetff  true  else  resetff' false; 
gt61o  srtff(  2,  first_eval  ); 

if  gt6hi  then 

rsvjplus  eomax 

else 

rswjplus  0.0: 

if  gt61o  then 

rsw_minus  eomax 

else 

rswjninus  :•  0.0; 
gt6  rsw_plus  -  rswjninus; 

gt7  delay_gt6 [ delay  Jiead} ; 

delay_gt6 [delay_tail]  gt6; 
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delay_head  delay_head  +  lj 
delay__tail  delay_tail  +  1; 

if  delay_head  -  delay__index  then  delayjiead  :«  0; 
if  delay_tail  -  delay_index  then  delay_tail  :«  0; 

if  f  z  >  0.0  then  fzpos  true  eXae  fzpos  false; 

if  gt7  >  half_eomax  then  gt7hi  j-  true  else  gt7hi  :»  false; 

if  gt7  <  -half_eomax  then  gt71o  true  else  gt71o  false; 

setff  dlyff(  first_eval,  gt7hi,  1  )  and  (  not  gt7hi  ); 

resetff  :«•  not  fzpos; 

tdtO  srtff(  3,  first_eval  ); 

setff  dlyff {  first_eval,  gt71o,  2  )  and  (  not  gt71o  ); 

resetff  fzpos; 

tutO  srtff (  4,  first_eval  ); 

tup  gt7hi  or  tutO; 

tdown  :•  gt71o  or  tdtO; 

if  tup  then  switch_up  p43  else  switch_up  0.0; 
if  tdown  then  switch_down  s-  -p43  else  switch_down  0.0; 
fzdot  switch_up  +  switch_down; 

Y_dot  fzdot; 

if  first_eval  then  mode  not(  tup  or  tdown  ); 


end;  . 


File:  BLOCK27.PAS 

Module  ProbleraJSpecifications; 

Public  Problem_Specifications; 

Procedure  Ini tial_Condit ions; 

Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first_eval  :  boolean; 
var  mode  :  boolean  ) ; 

Public  Solve_Differential_Equation; 

Var 

int_lirait , 

time,  h,  Y,  Y_dot  :  real; 
first_eval,  mode  :  boolean; 

$ Include  ( * : PFP : include/target .pas') 

Private  Problem_Specifications; 

const 


fyic 

- 

0.0; 

trf 

- 

4 .  OE-3, 

eomax 

- 

2.5; 

vl 

- 

0.24; 

v2 

- 

0.18; 

tdel 

- 

8.  OE-3 

f  side 

- 

380.0; 

real; 

integer; 


boolean; 

ly_srtff , 

oldy  :  array  11.. 4]  of  boolean; 

ly_dlyff , 


gp5,  fy, 

half_eoraax,  p43, 
gp7, 

gp6,  rswjalus, 

rswjninus, 

switch_up, 

switch_down, 

fydot 

delay_head, 
delay_tailr 
delay_index 
gpfihi,  gpfilo, 
setff,  resetff, 
fypos,  gp7hi, 
gp71o,  pdtO, 
putO,  pup,  pdown 


oldx 


:  array  [1..2]  of  boolean; 
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delay_gp6  :  array  [0..99]  of  real? 

Procedure  Initial_Conditions? 

var 

count  :  integer; 

message^type,  raessage_3ize  :  integer; 
begin 

input_me3sage<  raessage^type,  h,  rceasage^size  ); 

half_eoraax  !-  eoraax  /  2.0; 
p43  fside  /  trf; 

Y  fyic: 
int_limit  fside; 
delay_index  trunc(tdel/h)  *  4: 
for  count  :■  0  to  (delay_index  -  1)  do 
delay_gp€ {count]  0.0; 
time  0.0; 

delay_head  0; 

delay_tail  delay_index  -  1; 


end; 


Function  srtff(  index  :  integer;  first_time  :  boolean  )  :  boolean; 
begin 

if  time  -  0.0  then  begin 

ly_srtff [index]  false; 
oldy [index]  false; 

end 

else  if  first_time  then  begin 

if  setff  then  ly_artff [index]  true; 
if  resetff  then  ly_srtff [index]  false? 

if  (not  setff)  and  (not  resetff)  then  ly_3rtff [index]  oldyfindex]; 
if  setff  and  resetff  then  ly_srtff [index]  not  oldy[index]; 
oldyfindex]  ly_srtff [index] ; 

end; 

srtff  ly_3rtff [index]  ; 

end;  (  Function  3rtff  } 


Function  dlyf f (  first_time,  value  :  boolean;  index  :  integer  )  :  boolean; 


begin 


Digital  F.mulation  Technology  Laboratory  Final  Report 


if  time  -  0.0  then  begin 

ly__dlyff  [index]  false; 

oldx[ index]  value 

end 

else  if  first_time  then  begin 

ly_dlyff [index]  s-  oldx{ index ] ; 
oldx [index]  value 

end; 

dlyff  ly_dlyff [index] ; 

end;  {  Function  dlyff  } 


Procedure  Evaluate_Derivatives (  var  Y_dot  ;  Real;  Y,  time  :  Real 

first_eval  :  boolean; 
var  mode  :  boolean  ) ; 

{ 

Basic  Integrator  -  State  fy  -  Block  27 

}  * 

var 

count, 

kount  :  integer; 

begin 

fy  Y; 

Receive_Real_32bit (  gp5  ); 

Send_Real_32bit (  fy  ); 

{ 

if  first_eval  then  Output_Message <  Real_32bit,  fy,  1  ); 

} 

if  gp5  >  vl  then  setff  true  else  setff  false; 
if  gp5  <  -v2  then  resetff  true  else  resetff  false; 
gp6hi  srtff<  1,  first_eval  ); 

if  gp5  <  -vl  then  setff  true  else  setff  ;«  false; 
if  gpS  >  v2  then  resetff  true  else  resetff  s-  false; 
gp61o  3rtff(  2,  first_eval  ); 

if  gpfihi  then 

rsw_plus  eomax 

else 

rsw plus  0.0; 

if  gp61o  then 

rsw_minus  eomax 

else 

r  sw_minus  : -  0.0; 
gp6  rsw_plus  -  rsw_minus; 

gp7  delay_gp6 [delay_head] ; 
delay_gp6 [delay_tail]  gp6; 
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delay_head  :«•  delay_head  +  1; 
delay_tail  delay_tail  +  1; 

if  delay_head  -  delay_index  then  delay_head  0; 
if  delay_tail  -  delay_index  then  delay_tail  s-  0; 

if  fy  >  0.0  then  fypos  s-  true  else  fypos  s-  false; , 
if  gp7  >  half_eomax  then  gp7hi  true  else  gp7hi  false? 
if  gp7  <  -half_eomax  then  gp71o  true  else  gp71o  false; 
setff  dlyff<  first_eval,  gp7hi,  1  )  and  (  not  gp7hi  ); 
reset ff  not  fypos; 
pdtO  srtff(  3,  first_eval  ); 

setff  dlyff{  first_eval,  gp71o,  2  )  and  {  not  gp71o  ); 

reset ff  :•  fypos; 

putO  :•  srtff(  4,  first_eval  ); 

pup  ;*•  gp7hi  or  putO; 

pdown  gp71o  or  pdtO; 

if  pup  then  switch_up  p43  else  switch_up  0.0; 
if  pdown  then  switch_down  -p43  else  3witch_down  s-  0.0; 
fydot  switch__up  +  switch_down; 

Y_dot  fydot; 

if  first_eval  then  mode  : -  not (  pup  or  pdown  ) ; 


end? . 
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File:  BLOCK28 .PAS 

Module  Problem_Specifications; 

Public  P r obi era_Specificat ions; 

Procedure  Initial^Conditions; 

Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time 

first_eval  :  boolean  ) ; 

Public  Solve_Differential_Equation: 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

SInclude  ( * : PFP : include/target .pas’) 

Private  Problem_Specifications; 

const 

qsO  -  0,0; 

a  -  2.64; 

d  -  1.833; 

ix  -  25.77; 

thetaO  -  0.942; 

var 

riy,  rho,  us,  cmq, 
ws,  vns,  theta, 
craa,  rs,  ps,  lcmlcg, 
fz,  phi,  fy,  qs, 
p9,  plO,  ftz, 
sinphi,  co s phi, 
thetpr,  sinth,  W2, 
rsps,  rhous,  wswz, 
v36,  v33,  v37, 

qsdot  :  real; 


Procedure  Initial_Conditions; 

var 

raessage_type,  message_size  :  integer; 
begin 

inputjtessage (  message^ type,  h,  message_size  ); 


Real; 


p9  a  *  d  *  0.5; 
plO  a  *  d  *  d  *  0.25; 
Y  qsO; 
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time  :•  0.0; 


end; 


Procedure  Evaluate^Derivatives (  var  Y_dot  :  Real;  Y,  time 

first_eval  :  boolean  ) ; 

{ 

Basic  Integrator  -  State  qs  -  Block  28 

) 

begin 


{ 


qs  Y; 

Receive_Real_32bit ( 
Receive_Real_32bit { 
Receive_Real_32bit { 
Receive_Real_32bit ( 
Send_Real_32bit <  qs 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit  < 


us  ) ; 
ps  ); 
theta  > ; 
rs  ) ; 

)  ? 

phi  ) ; 
ws  ) ; 
rho  ) ; 
fz  ); 
fy  ); 
wns  ) ; 
riy  ) ; 
lcmlcg  ) ; 
croq  )  ; 
cm  a  )  ; 


if  first_eval  then  Output_Message (  Real_32bit,  qs,  1  ); 

> 


sinphi  sin(  phi  ); 

cosphi  :«  cos(  phi  ); 

ft z  f z  *  cosphi  -  fy  *  3inphi; 

v33  :»  lcmlcg  *  ftz; 

rhous  rho  *  us; 

thetpr  theta  +  thetaO; 

sinth  sin {  thetpr  ); 

wz  wns  *  sinth; 

wswz  ws  +  wz; 

rsps  r3  *  ps; 

v36  :«  rhous  *  (  plO  *  qs  *  cmq  +  p9  *  wswz  *  cma  )  - 
v37  v36  -  v33; 

qsdot  s-  riy  *  v37; 

Y_dot  :»  qsdot; 


end;  . 


:  Real; 


ix  *  rsps; 
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File:  BLOCK29.PAS 

Module  Problera_Specif icat ions ; 

Public  Problem_Specifications; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real:  Y,  time  :  Real; 

first_eval  :  boolean  ) ; 


Public  Solve_Differential_Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$ Include  ( ' :PFP:include/target.pas ’ ) 

Private  Problera_Specif icat ions; 

const 

thetic  -  0.0; 

var 

qs,  theta,  thetd  :  real; 


Procedure  initial^Conditions; 

var 

message_type,  message_size  :  integer; 

begin 

input_message  {  raessage_type,  h,  message__size  ) ; 

Y  thetic; 
time  0.0; 

end; 


Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first  eval  :  boolean  ) ; 


{ 


Basic  Integrator  -  State  theta  -  Block  29 


} 

begin 


theta  j-  Y; 

Send  Real  32bit (  theta  ) ; 
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Receive_Real_32bit (  qs  ) ; 

* 

if  first_eval  then  Output_Message (  Real_32bit, 
} 

thetd  qs; 

Y  dot  i-  thetd; 


theta,  1  ) ; 


end; . 
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File:  BLOCK30.PAS 

Module  Problem_Specifications; 

Public  Problem_Specifications; 

Procedure  lnitial_Conditions; 

Procedure  Bvaluate^Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first_eval  :  boolean  ) ; 

Public  Solve_Dif f erential_Equation ; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

^Include  {’ :PFP : include /target . pas » ) 

Private  Problem^Specifieations; 

const 

thetaO  -  0.942; 
psiic  •0.0; 

var 

ra,  theta,  psi, 

thetpr,  costh, 

rcos,  psidot  :  real; 


Procedure  Initial_Conditions; 


var 


message_type,  message_size  ;  integer; 


begin 

input_message (  message_type,  h,  message_size  ); 

Y  :•  psiic; 
time  0.0; 


end; 


Procedure  Evaluate_Derivatives (  var  Y_dot  ;  Real;  Y,  time  ;  Real; 

first_eval  :  boolean  ) ; 

Basic  Integrator  -  State  psi  -  Block  30 

) 

begin 
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psi  Y; 

Receive_Real_32bit (  theta  ) ; 

Receive_Real_32bit (  rs  ); 

Send_Real_32bit {  psi  ); 

{ 

if  first_eval  then  Output_Message (  Real_32bit,  psi,  1  ); 
} 

thetpr  theta  +  thetaO; 
costh  cos(  thetpr  ); 

reos  1.0  /  costh; 
psidot  rs  *  rcos; 

Y_dot  psidot 


end; . 
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File:  BLOCK3 1 . PAS 

Module  Problera__Specifications; 

Public  Problem^Specifications; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first  eval  :  boolean  ) ; 


Public  Solve_Differential_Equation; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  :  boolean; 

$ Include  ( * :PFP : include /target . pas  * ) 

Private  Problem_Specifications; 

const 

rsO  -  0.0; 

a  -  2.64; 

d  -  1.833; 

ix  -  25.77; 

var 

riy,  rho,  us,  anq, 
vs,  wwe, 

cma,  ps,  qs,  lcmlcg, 
fz,  phi,  fy,  rs, 
p9,  plO,  fty, 
sinphi,  cosphi,  vy, 
psqs,  rhous,  vswy, 
v40,  v43,  v44, 

rsdot  :  real; 


Procedure  Initial  Conditions; 


var 


raessage_type,  raessage_size :  integer; 
begin  1 

input_message (  message_type,  h,  message_size  ); 

p9:-a*d*0.5; 
plO  :«  a  *  d  *  d  *  0.25; 

Y  rsO; 
time  0.0; 
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end; 


Procedure  Evaluate^Derivatives <  var  Y_dot  :  Real;  Y,  time 

first_eval  !  boolean  ) ; 


[ 

Basic  Integrator  -  State  rs  -  Block  31 

) 

begin 


rs  Y; 

Receive_Real_32bit { 
Receive_Real_32bit { 
Reeeive_Real_32bit { 
Send_Real_32bit (  rs 
Receive_Real_32bit ( 
Recei ve_Re  a 1_3 2bi t ( 
Receive__Real_32bit  ( 
Recei ve_Rea 1_3 2 bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive^ Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 
Receive_Real_32bit ( 


us  ) ; 
ps  ); 
vs  ); 

); 

qs  ) ; 
phi  ); 
wwe  )  ; 
rho  ); 
fz  ) ; 
fy  ); 
riy  ) ; 
Icralcg  ) ; 
cmq  ) ; 
cma  ) ; 


if  first_eval  then 
begin 

Output_Message <  Character_08bit,  ’time-*,  5  ); 
Output_Message (  Real_32bit,  time,  1  ); 
Output_Message<  Character_08bit,  ’rs-’,  3  ); 
Output_Message (  Real_32bit,  rs,  1  ); 

Output_Hl; 

end; 

sinphi  sin(  phi  ); 

cosphi  cos (  phi  ) ; 

fty  fy  *  cosphi  +  fz  *  sinphi; 

v40  Icmlcg  *  fty; 

rhous  rho  *  us; 

wy  wwe; 

vswy  vs  -  wy; 

psqs  ps  *  qs; 

v43  rhou3  *  {  plO  *  rs  *  cmq  -  p9  *  vswy  *  cma  )  + 

v44  v43  -  v40; 

rsdot  riy  *  v44; 

Y_dot  rsdot; 


:  Real; 


ix  *  psqs; 


end;  . 
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File:  LMRK4.PAS 

Module  SolveJ)ifferential_Equation; 

Public  Problera^Specifications; 

Procedure  Initial_Conditions; 

Procedure  Evaluate_Derivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first_eval  :  boolean; 
var  mode  :  boolean  ) ; 


Public  Solve_Differential_Equation; 

Var 

int_limit , 

time,  h,  Y,  Y_dot  :  real; 
first_eval,  mode  :  boolean; 

Program  Solve_Differential__Equation; 


Procedure  Integrate_with_Lirait_and_Mode ; 

Integration  Routine  using  Fourth  Order  Runge-Kutta. 

var 

dumray_raode, 

upper_limit, 

in_limit  :  boolean; 

inv_three, 

kl,  k 2,  k3, 

half  h  :  real; 


) 


begin 

inv_three  1  /  3.0; 
half_h  0.5  *  h; 
in_limit  false; 
while  true  do  begin 

Evaluate_Derivatives (Y_dot,  Y,  time,  true,  mode); 
if  mode  then  begin 
kl  0.0; 
in_lirait  false; 

end 

else  begin 

if  not  in_limit  then  begin 

if  Y  >-  intJLimit  then  begin 
Y  int_limit: 
in_limit  true; 
upper_limit  :»  true; 

end 

else  if  Y  <-  -int_limit  then  begin 
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Y  i-  -int_lirait; 
in_limit  : -  true; 
upper  JLimit  false; 

end 

end 

else 

if  upper_limit  then  begin 

if  Y_dot  <  0.0  then  in_limit  false 

end 

else  begin 

if  Y— dot  >  0.0  then  in_limit  ;•  false 

end; 

if  in_limit  then  Y_dot  ; —  0.0; 
kl  Y  +  half_h  *  Y_dot; 

end; 

Evaluate_Derivatives <Y_dot,  kl,  time  +  half_h,  false,  dummy_mode) ; 
if  mode  then 
k 2  0.0 

else  begin 

if  in_limit  then  Y_dot  0.0; 

.  k2  Y  +  half_h  *  Y_dot; 

end; 

Evaluate_Derivatives (Y_dot,  k2,  time  +  half_h,  false,  dummy_mode) ; 
if  mode  then 
k3  0.0 

else  begin 

if  in_limit  then  Y_dot  0.0; 

k3  Y  +  h  *  Y_dot; 

end; 

Evaluate_Derivatives(Y_dot,  k3.  time  +  h,  false,  dummy _mode); 
if  mode  then 

Y  0.0 
else  begin 

if  in_limit  then  Y_dot  0.0; 

Y  <  kl  +  2 . 0*k2  +  k3  +  half_h  *  Y_dot  -  Y  )  *  inv_three; 

end; 

time  time  +  h; 

end; 

end;  {  PROCEDURE  Integrate_with_Limit_and_Mode  } 


begin 


Initial_Conditions; 
Integrate_with_Lirait_and_Mode ; 


end. 
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File:  LRK4.PAS 

Module  Solve_Differential_Equation; 

Public  ProbleraJSpecifications; 

Procedure  Initial_Conditions; 

Procedure  EvaluateJDerivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

f irst_eval  :  boolean  ) ; 

Public  Solve_Differential_Equation; 

Var 

int_limit, 

tine,  h,  Y,  Y_dot  :  real? 
first__eval  :  boolean; 

Program  Solve_Differential_Equation: 


Procedure  Integrate__with_Limit; 

{ 

Integration  Routine  using  Fourth  Order  Runge-Kutta. 

var 

upper_limit, 
in_limit  :  boolean; 

inv_three, 
kl,  k2,  k3» 

half_h  :  real;  * 

begin 

inv_three  1  /  3.0; 

half_h  : —  0.5  *  h  ? 
in_limit  false: 
while  true  do  begin 

Evaluate^ Derivatives (Y_dot ,  Y.  time,  true); 
if  not  in_limit  then  begin 

if  Y  >-  int_lirait  then  begin 

Y  int_limit; 

in— limit  :*■  true; 
upper_limit  true; 

end 

else  if  Y  O  -int_limit  then  begin 

Y  -int_limit; 

in_limit  true; 
upper_limit  false; 

end 

end 

else 

if  upper^limit  then  begin 
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if  Y_dot  <0.0  then  in_limit  false 

end 

else  begin 

if  Y_dot  >  0.0  then  in^lirait  false 

end; 

if  in_limit  then  Y_dot  0.0; 
kl  Y  +  half_h  *  Y_dot; 

Evaluate_Derivatives (Y_dot,  kl,  time  +  half_h,  false); 
if  in_ limit  then  Y_dot  0.0; 

k2  Y  +  halfji  *  Y_dot; 

Evaluate_Derivatives (Y_dot,  k2,  time  +  half_h,  false); 
if  inj.imit  then  Y_dot  0.0; 

k3  Y  +  h  *  Y_dot; 

EvaluateJDerivatives <Y_dot,  k3,  time  +  h,  false); 
if  in_limit  then  Y__dot  0.0; 

Y  s-  <  kl  +  2 .0*k2  +  k3  +  halfji  *  Y_dot  -  Y  )  *  inv_three; 

time  time  +  h; 

end; 

end;  {  PROCEDURE  Integrate_with_Limit  ) 


begin 


Initial_Conditions ; 
Integrat e_with_Limit ; 


end. 
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FilAS  MAKEFILE 

PASFLAGS  -  large  optimize (1)  symbolspace(64) 

PROGRAM  -  \ 

blockOO. bl  \ 
blockOl.bl  \ 
block02.bl  \ 
block03.bl  \ 
blocJc04.bl  \ 
blockOS.bl  \ 
bloc)c06.bl  \ 
block07 .bl  \ 
blockOS.bl  \ 
block09.bl  \ 
blocklO.bl  \ 
blockll.bl  \ 
bloclcl2.bl  \ 
bloc)cl3.bl  \ 
blockl4 .bl  \ 
blocklS.bl  \ 
blocklS.bl  \ 
blockl7.bl  \ 
blockl8.bl  \ 
blockl9.bl  \ 
block20.bl  \ 
block21.bl  \ 
block22.bl  \ 
block23.bl  \ 
block24.bl  \ 
block2S.bl  \ 
block26.bl  \ 
block27.bl  \ 
block28.bl  \ 
block29.bl  \ 
block30.bl  \ 
block31 .bl  \ 
crossbar. bl  \ 
sequencer . bl 

default:  $ (PROGRAM) 

blockOO.bl:  blockOO.obj  table. obj 

submit  :PFP:csd/pasbldl(  blockOO,  ‘blockOO . obj . table. obj ’  ) 

blockOO.obj:  blockOO. pas 

pas28€  blockOO. pas  $<PASFLAGS) 

blockOl.bl:  blockOl.obj  table. obj 

submit  :PFP:csd/pasbldl (  blockOl.  'blockOl .obj, table. obj '  ) 

blockOl.obj:  blockOl. pas 


L 
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pa 32 8 6  blockOl.pas  $(PASFLAGS) 

block02.bl:  block02.obj  table. obj 

submit  : PFP : csd/pasbldl (  block02,  ’ block02. obj, table. ob j T  ) 

block02.obj:  block02.pas 

pas286  block02 .pas  ${PASFLAGS) 

block03.bl:  block03.obj  table. obj 

submit  :PFP :csd/pasbldl (  block03,  ’block03 . obj, table. obj ’  ) 

blockOS.obj:  block03.pas 

pas28€  block03 .pas  ${PASFLAGS) 

block04.bl:  block04.obj  table. obj 

submit  :PFP:csd/pa3bldl (  block04,  ’block04 .obj, table. obj *  ) 

block04.obj:  block04.pas 

pas286  block04 .pas  $<PASFLAGS) 

blockOS.bl:  block05.obj  table. obj 

submit  : PFP : csd/pasbldl (  blockOS,  ’block05 .obj, table. obj f  ) 

blockOS.obj:  blockOS.pas 

pas286  blockOS.pas  $(PASFLAGS) 

block06.bl:  block06.obj  table. obj 

submit  : PFP : csd/pasbldl (  blockOC,  * blockOS.obj, table. obj *  ) 

blockOS.obj:  blockOS.pas 

pas286  blockOS.pas  S(PASFLAGS) 

block07.bl:  block07.obj  table. obj 

submit  :PFP : csd/pasbldl (  block07,  ’block07 . obj, table. obj ’  ) 

block07.obj:  block07.pas 

pas286  block07 . pas  $(PASFLAGS) 

blockOS . bl :  blockOS.obj  table. obj 

submit  : PFP: csd/pasbldl (  block08,  ’blockOS.obj, table. obj’  ) 

blockOS.obj:  block08.pas 

pas286  block08 .pas  $<PASFLAGS) 

block09.bl:  block09.obj  table. obj 

submit  j PFP: csd/pasbldl (  block09,  * block09 . obj , table, obj *  ) 

block09.obj:  block09.pas 

pas286  block09.pas  ${PASFLAGS) 


blocklO.bl: 


blocklO.obj  table. obj 
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submit  :PFP : csd/pasbldl <  blocklO,  ‘blocklO . obj, table. obj '  ) 

blocklO .obj :  blocklO .pas 

pas286  blocklO. pas  ${PASFLAGS) 

blockll.bl:  blockll.obj  table. obj 

submit  : PFP : csd/pasbldl (  blockll,  ’blockll .obj , table .obj '  ) 

blockll.obj:  blockll. pas 

pas286  blockll. pas  $<PASFLAGS) 

blockl2.bl:  blockl2.obj  table. obj 

submit  : PFP: csd/pasbldl (  blockl2,  ’blockl2 .obj, table. obj *  ) 

blockl2 .obj :  blockl2.pas 

pas286  blockl2.pas  $(PASFLAGS) 

blockl3.bl:  blockl3.obj  table. obj 

submit  :PFP : csd/pasbldl (  blockl3,  ‘blockl3 .obj, table. obj ’  ) 

blockl3 . obj :  blockl3.pas 

pas286  blockl3 .pas  $(PASFLAGS) 

block 14 .bl :  blockl4.obj  rk4.obj 

submit  :PFP :csd/pasbldl (  blockl4,  fblockl4 . obj , rk4 . obj '  ) 

blockl4.obj:  blockl4.pas 

pa s28 6  blockl4.pas  $(PASFLAGS) 

blocklS.bl:  blocklS.obj  rk4.obj 

submit  :PFP tcsd/paabldl (  blocklS,  'blockl 5 .obj, rk4 .obj *  ) 

blocklS.obj:  blocklS. pas 

pas286  blocklS. pas  S(PASFLAGS) 

blockl 6. bl:  blocklS.obj  rk4.obj 

submit  : PFP: csd/pasbldl (  blocklS,  'blocklS. obj, rk4 . obj '  ) 

blocklS.obj:  blocklS. pa3 

pas28S  blocklS. pas  $(PASFLAGS) 

blockl7.bl:  blockl7.obj  rk4.obj 

submit  : PFP: csd/pasbldl {  blockl7,  ’blockl7 . obj , rk4 . obj ’  ) 

blockl7.obj:  blockl7.pas 

pas286  blockl7 .pas  $(PASFLAGS) 

blockl 8 .bl :  blockl8.obj  rk4.obj 

submit  :PFP: csd/pasbldl (  blockl8,  'blocklS . obj , rk4 .obj ‘  ) 


blockl 8 . obj : 


blocklS .pas 
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pas28€  blocklS .pas  $<PASFLAGS) 

blockl9.bl:  blockl9.obj  rk4.obj 

submit  :PFP:csd/pasblcil  (  blockl9,  ’blockl9.obj, rk4 .obj '  ) 

blockl9.obj:  blockl9.pas 

pas286  blockl9.pas  $(PASFLAGS) 

block20.bl:  block20.obj  rk4.obj 

submit  :PFP:csd/pasbidl (  block20,  'block20.obj, rk4 .obj '  ) 

block20.obj:  block20.pas 

pas286  bloc k20 .pas  ${PASFLAGS) 

block21.blj  block21.obj  rk4.obj 

submit  :PFP:csd/pasbldl (  block21,  *block21 .obj, rk4 .obj *  ) 

block21.obj:  block21.pas 

pas286  block21.pas  ${PASFLAGS) 

block22.bl:  block22.obj  rk4.obj 

submit  :PFP:csd/pasbldl(  block22,  *block22 .obj, rk4 .obj *  ) 

block22.obj:  block22.pas 

pas286  block22.pas  ${PASFLAGS) 

block23 .bl;  block23.obj  rk4.obj 

submit  :PFP:csd/pasbldl(  block23,  fblock23 .obj, rk4 .obj •  ) 

block23 . obj :  block23 . pas 

pas286  block23.pas  $(PASFLAGS) 

block24.bl:  block24.obj  lrk4.obj 

submit  : PFP : csd/pasbldl (  block24,  *block24 .obj, lrk4 .obj »  ) 

block24 .obj :  block24.pas 

pas286  block24.pas  $(PASFLAGS) 

block25.bl:  block25.obj  lrk4.obj 

submit  : PFP: csd/pasbldl (  block25,  *block25 .obj , lrk4 .obj •  ) 

block25.obj:  block2S.pas 

pas286  block25.pas  $(PASFLAGS) 

block26.bl:  block26.obj  lmrk4.obj 

submit  :PFP: csd/pasbldl (  block26,  ' block26 .obj , lmrk4 . ob j 1  ) 

block26.obj:  block26.pas 

pas286  block26.pas  $(PASFLAGS) 

block27.bl:  block27.obj  lmrk4.obj 
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submit  :PFP: csd/pasbldl (  block27,  *block27 .obj , lmrk4 .obj ’  ) 

block27.obj :  block27.pas 

pas286  block27 .pas  $(PASFLAGS) 

block28.bl:  block28.obj  rk4.obj 

submit  :PFP : csd/pasbldl (  block28,  *block28.obj, rk4 .objt  ) 

bloek28.obj:  block28.pas 

pas286  block28 .pas  $<PASFLAGS) 

block29.bl:  block29.obj  rk4.obj 

submit  :PFP : csd/pasbldl (  block29,  fblock29 . obj, rk4 .obj *  ) 

block2 9 . ob j :  block2  9 . pa  s 

pas286  block29.pas  ${PASFLAGS) 

block30.bl:  block30.obj  rk4.obj 

submit  :PFP: csd/pasbldl (  block30,  ’block30 .obj, rk4 .obj’  ) 

block30.obj:  block30.pas 

pas286  block3 0 .pas  $(PASFLAGS) 

block3 1 .bl:  block31.obj  rk4.obj 

submit  :PFP: csd/pasbldl {  block31,  *block31 .obj, rk4 . obj '  ) 

block3 1. obj:  block31.pas 

pas286  blocks 1 .pas  $(PASFLAGS) 

lmrk4 .obj :  lrark4.pas 

pas286  lmrk4,pas  $(PASFLAGS) 

lrk4.obj:  Irk4.pa3 

pas286  lrk4 .pas  $(PASFLAGS) 

rk4.obj:  rk4.pas 

pas286  rk4.pas  $<PASFLAGS) 

table. obj:  table. pas 

pas286  table. pas  $(PASFLAGS) 

crossbar. bl  sequencer .bl:  network.txt 

submit  :PFP:csd/xbc{  network.txt  ) 

clean: 

delete  * . 1st, * .obj, * .mp?, * .bl 

run:  $ (PROGRAM) 
reset 

download  process.txt 
start  proces3.txt 


File:  NETWORK . TXT 


t  Spinning  Missile  -  Crossbar  setup  ] 

loop 

cycle  [  1  J 


p23  p21.2; 

t  state  -  gp2  ] 

p27  p25.2; 

[  state  -  gp5  ] 

p22  p20 .2; 

t  state  -  gt2  ] 

p26  p24 . 2r 

[  state  -  gt5  ] 

pll,  pl2,  pl3. 

plS,  pl6,  pi 7, 

pl9,  p28 ,  p31 

pl4 .2 

t  state  -  us  ] 

cycle  [  2  ] 

p25  p23.2; 

{  state  -  gp4  ] 

p24  p22.2; 

I  state  -  gt4  ] 

pl8,  p28,  p31 

pl7 .2; 

[  state  -  ps  ] 

pi 4  plS .2; 

[  state  -  vs  } 

p8,  p9,  plO 

pi 9 . 2 : 

[  state  -  z  1 

cycle  {  3  ] 

pl7  p4 .2; 

[  table  -  ltf  ] 

pl4 ,  pl6,  pi 8, 

pl9,  p20,  p21. 

p22. 

p23,  p28,  p30 

p2 9 . 2 ; 

I  state  -  theta 

p31  plS .2; 

I  state  -  vs  ] 

cycle  [  4  ] 
pl4,  plS, 

pl8,  p28 ,  p30  p31.2;  t  state  -  rs  ] 


cycle  (  5  } 

p20,  p21 , 

p22,  p23  p30 .2;  [  state  -  psi  ] 

pl4 ,  pl6, 

p29,  p31  p2  8 . 2 ;  £  state  -  qs  ] 

cycle  [  6  ] 

pl4  pi. 2;  [  table  -  tf  ] 

plS,  pl6,  p20, 
p21,  p22, 

p23,  p28 ,  p31  pl8.2;  [  state  -  phi  ) 

cycle  [  7  ] 

plS,  p31  p9.2;  {  table  -  wwef  ] 

pl4,  pl9,  p28  pl6.2;  [  state  -  ws  I 

cycle  [  8  ] 

pl4,  plS,  pl6. 

pl7,  p28,  p31  pl0.2:  t  table  -  rhof  ] 

cycle  [  9  ] 

p!4  p5 . 2 ;  [  table  -  acdOf  ] 

plS ,  pl6, 

p28.  p31  p2 6 . 2 ;  (  state  -  fz  ] 

cycle  [  10  ] 


pl7  pl3 .2; 


[  table  -  clpf  ] 
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pis,  pl6, 

p28,  p31  s-  p2 7 . 2 ; 

[  state  -  fy  ] 

cycle  [  11  ] 

pH,  pl6,  p28  p8 . 2; 

[  table  -  wnsf  ] 

cycle  [  12  ] 

pl5,  pl6  pll.2; 

[  table  -  acnaf  ] 

p28 ,  p31  p2.2: 

[  table  -  riyf  ] 

cycle  [  13  ] 

pl7  pl2 .2; 

(  table  -  cldtf  ] 

p28 ,  p31  t-  p3 . 2 ; 

t  table  -  lclcgf 

pl4,  plS.  pi 6  p0.2; 

[  table  -  rref  ] 

cycle  [  14  I 

p28,  p31  :«*  p7 .2; 

(  table  -  craqf  J 

cycle  [  15  ] 

p28,  p31  i-  p6.2; 

[  table  -  cmaf  ] 

File:  PROCESS . TXT 

p32  blockOO.bl  smissile.txt  <null> 
p33  blockOl.bl  smissile.txt  <null> 
p34  block02.bl  smissile.txt  <null> 
p35  block03.bl  smissile.txt  <null> 
p36  block04.bl  smissile.txt  <null> 
p37  block05.bl  smissile.txt  <null> 
p38  blockOS.bl  smissile.txt  <null> 
p39  block07.bl  smissile.txt  <null> 
p40  blockOS.bl  smissile.txt  <null> 
p41  block09.bl  smissile.txt  <null> 
p42  bloeklO.bl  smissile.txt  <null> 
p43  blockll.bl  smissile.txt  <null> 
p44  blockl2.bl  smissile.txt  <null> 
p45  blockl3.bl  smissile.txt  <null> 
p46  blockl4.bl  smissile.txt  <null> 
p47  blocklS.bl  smissile.txt  <null> 
p48  blocklS.bl  smissile.txt  <null> 
p49  blockl7.bl  smissile.txt  <null> 
p50  blockl8.bl  smissile.txt  <null> 
pSl  blockl9.bl  smissile.txt  <null> 
p52  block20.bl  smissile.txt  <null> 
p53  block21.bl  smissile.txt  <null> 
p54  block22.bl  smissile.txt  <null> 
p55  block23.bl  smissile.txt  <null> 
p56  block24.bl  smissile.txt  <null> 
p57  block25.bl  smissile.txt  <null> 
p58  block26.bl  smissile.txt  <null> 
p59  block27.bl  smissile.txt  <null> 
p60  block28.bl  smissile.txt  <null> 
p61  block29.bl  smissile.txt  <null> 
p62  block30.bl  smissile.txt  <null> 
p63  block31.bl  smissile.txt  <null> 
crossbar  crossbar. bl  <null>  <null> 
sequencer  sequencer. bl  <null>  <null> 
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File:  RK4.PAS 

Module  Sol ve_Di f f er ent ia 1 _Equat ion ; 

Public  Problem^Specifications; 

Procedure  Initial_Conditions; 

Procedure  BvaluateJDerivatives (  var  Y_dot  :  Real;  Y,  time  :  Real; 

first_eval  :  boolean  ) ; 


Public  Solve JDi f f er entia l_Equa tion ; 

Var 

time,  h,  Y,  Y_dot  :  real; 
first_eval  s  boolean; 

Program  SolveJ3ifferential_Equation; 


Procedure  Integrate; 

( 

Integration  Routine  using  Fourth  Order  Runge-Kutta. 

> 

var 

inv_three, 
kl,  k2,  k3, 
half_h  :  real; 

begin 

inv_three  1  /  3.0; 

half_h  0.5  *  h; 
while  true  do  begin 

BvaluateJDerivatives  (Y__  dot,  Y,  time,  true); 
kl  Y  +  half _h  *  Y_dot; 

Evaluate_Derivatives(Y_dot,  kl,  time  +  half_h,  false); 
k2  Y  +  halfjh  *  Y_dot; 

Evaluate_Derivatives (Yjdot,  k2,  time  +  half_h,  false); 
k3  Y  +  h  *  Yjdot; 

Evaluate_Derivatives (Y_dot,  k3,  time  +  h,  false); 

Y  {  kl  +  2 .  0*k2  +  k3  +  halfji  *  Y_dot  -  Y  )  *  inv_three 
time  time  +  h; 

end; 

end;  {  PROCEDURE  Integrate  } 


begin 


Initial_Conditions; 


Integrate; 
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end. 
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File:  SMISSILE.TXT 
#  integration  »tep 
real_32bit 
1 

0.0005 
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File:  TABLE. FAS 
Module  Solve  JTable; 

Public  ProblemjSpecifications? 

Procedure  Initialize_Table; 

Procedure  Evaluate_Table (  time  :  Real  ) ; 

Public  Solve_Table? 

Var  time,  integration_step  :  Real; 

Program  Solve_Table? 

Procedure  Table_Value; 

var 

half_step  :  real: 

begin 

time  : -  0.0; 

half_step  0.5  *  integration_step; 
while  true  do  begin 

Evaluate_Table (  time  ) ; 

Evaluate_Table {  time  +  half_step  ) ; 
Evaluate_Table (  time  +  half_step  ); 
Evaluate_Table (  time  +  integration_step  ) ; 
time  time  +  Integra tion_step; 

end; 

end;  {  Procedure  Table_Value  } 

begin 

Initialize_Table; 

Table  Value; 


{  time  } 

{  time+0 .  5*h  ) 
{  time+0 . 5*h  } 
{  time+h  } 


end. 


